Resposta
Extrair Elemento
Primeiro a função de extrair elemento é declarada para extrair os elementos separados por espaço " "
, em que cada elemento possui um index.
Exemplo.: 1 a 3
na célula A1, com a função EXTRACTELEMENT("A1",1," ")
a resposta é 1
e para EXTRACTELEMENT("A1",2," ")
a resposta é a
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
EXTRACTELEMENT = Split(Application.Trim(Txt), Separator)(n - 1)
End Function
Expandir (Código Principal)
Este código não está otimizado e se a planilha for muito grande (mais de 50 mil linhas), pode se tornar lenta.
Os elementos precisam ser em ordem ascendente, por exemplo:
+---+---------+
| | A |
+---+---------+
| 1 | 1 a 3 |
| 2 | 6 a 9 |
| 3 | 20 a 23 |
+---+---------+
No entanto, se for fora de ordem, um erro ocorre. Por exemplo:
+---+---------+
| | A |
+---+---------+
| 1 | 1 a 3 |
| 2 | 20 a 23 |
| 3 | 15 a 9 |
+---+---------+
Caso não seja em ordem ascendente, algumas condicionais devem ser adicionadas.
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
Opcional, descrição da função definida por usuário(UDF)
Adiciona descrição da função para ser mostrada ao utilizá-la na planilha Excel.
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
Opcional
Este código não realiza o que foi perguntado, por falta de atenção a
tarefa contrária foi escrita.Porém pode ser utilizado após o código do
Evert para agrupar e tornar planilhas muito grandes mais organizadas.
Este código primeiro reordena os dados da coluna B em ordem crescente, depois enumera na coluna A de 1 à última célula.
Após isso agrupa os dados.
Conforme a imagem
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
A seguir serão divididos cada parte do código para melhor entendê-lo
Desagrupamento
É realizado para reordenar corretamente a coluna 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
Ordenação
Usa o Range.Sort para ordenar os valores da coluna B, este código foi retirado deste link
Range("B1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Enumeração
Enumera até a última linha com o Autofill, a ferramenta de preenchimento automático do Excel, em que após selecionar o Range, dois cliques são dados no ponto preto do canto inferior da seleção
For i = 1 To 4
ws.Cells(i, 1) = i
Next i
Range("A1:A4").AutoFill Destination:=Range("A1:A" & rLastB)
Agrupamento
Este código foi retirado do SO Global e realiza o agrupamento
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