As I would in excel to expand a huge list with data to instead of grouping value data, it would show the content in total. Example:
I would like to turn this:
Inthis:
Remembering it will be a huge list of values. So something automated would help a lot.
My suggestion is as follows:
Create a code to fetch the cell numbers, as follows:
Function Extrair_Numero(ByRef TEXTO As String, _
Optional ByRef SEQUENCIAL As Integer = 1) As Double
Dim i As Integer
Dim COUNT As Integer
Dim TEMP As String
Dim RESULTADO As Double
For i = 1 To Len(TEXTO)
TEMP = Mid(TEXTO, i, 1)
If IsNumeric(TEMP) Then
RESULTADO = RESULTADO & TEMP
ElseIf RESULTADO > 0 Then
COUNT = COUNT + 1
If RESULTADO > 0 And SEQUENCIAL = COUNT Then
Extrair_Numero = CDbl(RESULTADO)
Exit Function
ElseIf COUNT > 0 And SEQUENCIAL > COUNT Then
RESULTADO = Empty
End If
End If
Next
Extrair_Numero = CDbl(RESULTADO)
End Function
This is a function that returns the number from a string , and can return the number in a certain position, or sequence.
Example: in string "12 13 15 18"
12 would be the first (1), the second (2), the third (3), and so on.
Create a loop to copy your data to the desired destination.
Sub Copia_Dados()
Dim PLANILHA_ORIGEM As String
Dim PLANILHA_DESTINO As String
Dim COLUNA_CODIGO As String
Dim COLUNA_DADOS As String
Dim CELULA_DESTINO_CODIGO As String
Dim CELULA_DESTINO_DADOS As String
Dim rCODIGO As Range
Dim rDADOS As Range
Dim rCell As Range
Dim NUM_INI As Double
Dim NUM_FIM As Double
Dim i As Integer
Application.ScreenUpdating = False
' Define as planilhas
PLANILHA_ORIGEM = "Plan1"
PLANILHA_DESTINO = "Plan2"
' Define as colunas de código e dados (ORIGEM)
COLUNA_CODIGO = "A"
COLUNA_DADOS = "B"
' Define as células iniciias para código e dados (DESTINO)
CELULA_DESTINO_CODIGO = "A1"
CELULA_DESTINO_DADOS = "B1"
' Busca os dados das colunas com códigos e dados
Set rCODIGO = Sheets(PLANILHA_ORIGEM).UsedRange.Columns(COLUNA_CODIGO)
Set rDADOS = Sheets(PLANILHA_ORIGEM).UsedRange.Columns(COLUNA_DADOS)
' Loop na coluna de código
For Each rCell In rCODIGO.Cells
' Buscas os números da célula
NUM_INI = Extrair_Numero(rCell.Text, 1)
NUM_FIM = Extrair_Numero(rCell.Text, 2)
If NUM_INI < NUM_FIM Then
For i = NUM_INI To NUM_FIM
' Preenche os dados
Sheets(PLANILHA_DESTINO).Range(CELULA_DESTINO_CODIGO).Offset(i - 1, 0).Value = i
Sheets(PLANILHA_DESTINO).Range(CELULA_DESTINO_DADOS).Offset(i - 1, 0).Value = Sheets(PLANILHA_ORIGEM).Range(COLUNA_DADOS & rCell.Row).Value
Next
Else
MsgBox "Os números '" & rCell.Text & "' informado em '" & rCell.Address & "' não estão em sequência!", vbInformation, "Erro"
Exit Sub
End If
Next
End Sub
Pay attention to the variable settings so that the data is transferred from the desired source location to the destination location.
I tried to make it as abstract as possible.
In the current code, if your sequence is not continuous, for example 1 to 10 and then 30 to 40, the destination worksheet will have a gap of 11 to 29, however if this way you do not answer you can adapt something to not skip the cells, or delete the blank cells later.
Smart to help!
First, the extract element function is declared to extract elements separated by space " " , where each element has an index.
Example: 1 a 3 in cell A1, with the function EXTRACTELEMENT("A1",1," ") the answer is 1 and for EXTRACTELEMENT("A1",2," ") the answer is a
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
EXTRACTELEMENT = Split(Application.Trim(Txt), Separator)(n - 1)
End Function
This code is not optimized, and if the spreadsheet is too large (over 50,000 rows), it can become slow.
Elements must be in ascending order, for example:
+---+---------+
| | A |
+---+---------+
| 1 | 1 a 3 |
| 2 | 6 a 9 |
| 3 | 20 a 23 |
+---+---------+
However, if it is out of order, an error occurs. For example:
+---+---------+
| | A |
+---+---------+
| 1 | 1 a 3 |
| 2 | 20 a 23 |
| 3 | 15 a 9 |
+---+---------+
If it is not in ascending order, some conditionals must be added.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
Do While y <> 1
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If i - 1 = lastrow Or lastrow = 1 Then y = 1
For i = 1 To lastrow
Let Rng = "A" & i
If IsNumeric(ws.Range(Rng)) = False And ws.Range(Rng).Value <> "" Then
ele1 = EXTRACTELEMENT(ws.Range(Rng), 1, " ")
ele2 = EXTRACTELEMENT(ws.Range(Rng), 3, " ")
On Error Resume Next
j = ws.Range(Rng).Row
x = CLng(ele2) - j
Rows(j & ":" & j + x).Insert
Z = ws.Cells(j + x + 1, 2)
For k = ele1 To ele2
ws.Cells(k, 1) = k
ws.Cells(k, 2) = Z
Next k
Rows(j + x + 1).EntireRow.Delete
End If
Next i
Loop
Add function description to be shown when using it in Excel spreadsheet.
Sub DescribeFunction()
Dim FuncName As String
Dim FuncDesc As String
Dim Category As String
Dim ArgDesc(1 To 3) As String
FuncName = "EXTRACTELEMENT"
FuncDesc = "Returns the nth element of a string that uses a separator character/Retorna o enésimo elemento da string que usa um caractér separador."
Category = 7 'Text category
ArgDesc(1) = "String that contains the elements/String que contém o elemento"
ArgDesc(2) = "Element number to return/ Número do elemento a retornar"
ArgDesc(3) = "Single-character element separator/ Elemento único separador (spc por padrão)"
Application.MacroOptions _
Macro:=FuncName, _
Description:=FuncDesc, _
Category:=Category, _
ArgumentDescriptions:=ArgDesc
End Sub
This code does not accomplish what was asked, due to lack of attention to The opposite task was written. However, it can be used after the Evert to group and make very large spreadsheets more organized.
This code first reorders the data in column B in ascending order, then enumerates in column A of 1 to the last cell. After that, gather the data.
According to the image
DimwsAsWorksheetApplication.ScreenUpdating=FalseSetws=ThisWorkbook.Sheets(1)rLastA=ws.Cells(ws.Rows.Count,1).End(xlUp).RowrLastB=ws.Cells(ws.Rows.Count,2).End(xlUp).RowWithwsOnErrorResumeNext.Outline.ShowLevelsRowLevels:=8.Rows.UngroupOnErrorGoTo0Setr=ws.Range(ws.Cells(1,2),ws.Cells(rLastB,2))EndWithRange("B1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = 1 To 4
ws.Cells(i, 1) = i
Next i
Range("A1:A4").AutoFill Destination:=Range("A1:A" & rLastB)
With r
'identify common groups in column B
j = 1
v = .Cells(j, 1).Value
For i = 2 To .Rows.Count
If v <> .Cells(i, 1) Then
' Colum B changed, create group
v = .Cells(i, 1)
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
j = i
v = .Cells(j, 1).Value
End If
Next
' create last group
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
' collapse all groups
.Parent.Outline.ShowLevels RowLevels:=1
End With
Application.ScreenUpdating = True
Ungrouping
Is performed to properly reorder column B
With ws
On Error Resume Next
.Outline.ShowLevels RowLevels:=8
.Rows.Ungroup
On Error GoTo 0
Set r = ws.Range(ws.Cells(1, 2), ws.Cells(rLastB, 2))
End With
Sorting
Use the Range.Sort to sort the values in column B, this code has been removed of this link
Range("B1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Enumeration
Lists up to the last line with Autofill, the AutoFill tool for Excel, where after selecting the Range, two clicks are given at the black dot in the lower corner of the selection
For i = 1 To 4
ws.Cells(i, 1) = i
Next i
Range("A1:A4").AutoFill Destination:=Range("A1:A" & rLastB)
Grouping
This code has been removed from the Global OS and performs grouping
With r
'identify common groups in column B
j = 1
v = .Cells(j, 1).Value
For i = 2 To .Rows.Count
If v <> .Cells(i, 1) Then
' Colum B changed, create group
v = .Cells(i, 1)
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
j = i
v = .Cells(j, 1).Value
End If
Next
' create last group
If i > j + 1 Then
.Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
End If
' collapse all groups
.Parent.Outline.ShowLevels RowLevels:=1
End With