2
As I would in excel to expand a huge list with data to instead of grouping value data, it shows the content in total. Example:
I’d like to transform that:
Therein:
Remembering that it will be a huge list of values. So something automated would help a lot.
3
My suggestion is this::
Create a code to fetch 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, can return the number at a given position, or sequence.
Example: in string "12 13 15 18"
12 would be the first (1), 13 the second (2), 15 the third (3) and so on.
Creates 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
Note the variable settings so that data is transferred from the desired source location to the destination location.
I tried to keep it as abstract as possible.
In the current code, if its sequence is not continuous, for example 1 to 10 and then 30 to 40, the target sheet will have a "gap" from 11 to 29, however if this way does not meet can adapt something not to skip the cells, or delete blank cells later.
Smart to have helped!
Oops! It worked here! Excellent! Thank you very much, Evert! :)
1
First the extract element function is declared to extract space-separated elements " ", where each element has an index.
Example.: 1 a 3 in cell A1, with the function EXTRACTELEMENT("A1",1," ") the answer is 1 and to 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 (more than 50 thousand lines), it can become slow.
The elements need to 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 not in ascending order, some conditionals should 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 perform what was asked, for lack of attention to opposite task was written. However it can be used after the Evert to group and make much larger spreadsheets more organized.
This code first reorders the data in column B in ascending order, then enumerates in column A from 1 to the last cell. After that groups the data.
According to the image
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets(1)
rLastA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
rLastB = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
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
Range("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
Disaggregation
It is performed to correctly 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
Ordination
Use Range.Sort to sort the values of 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
Enumerate up to the last line with Autofill, the Excel Auto Fill tool, where after selecting the Range, two clicks are given at the black point of 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
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
Hahaha... Take it easy! I was trying to understand what you meant by the answer. Thanks for your time anyway. :)
Browser other questions tagged excel vba
You are not signed in. Login or sign up in order to post.
The initial spreadsheet will always have this same pattern?
– Evert
@Evert The idea is to have this same structure. What could be different at most is that instead of being "1 to 10", it could be "1-10" or something like that. But the whole column will follow the same logic.
– Leon Freire
Okay, we’re gonna need a VBA to do this... I’m gonna try to post something here to help you and see if you can get it into production there.
– Evert
@Evert Thank you so much!
– Leon Freire