Macro do Excel - células separadas por vírgula para linhas preservam / agregam coluna
Eu tive uma pergunta semelhante respondidaAqui
Há uma ligeira reviravolta no cenário e esperamos que a macro possa ser ligeiramente alterada. Qualquer ajuda é apreciada.
Com base nestes dados:
<- A (Category) -> <- B (Items) ->
1 Cat1 a,b, c
2 Cat2 d
3 Cat3 e
4 Cat4 f, g
Eu preciso disso:
<- A (Category) -> <- B (Items) ->
1 Cat1 a
2 Cat1 b
3 Cat1 c
4 Cat2 d
5 Cat3 e
6 Cat4 f
7 Cat4 g
Esta é a macro existente:
Option Explicit
Sub Macro1()
Dim fromCol As String
Dim toCol As String
Dim fromRow As String
Dim toRow As String
Dim inVal As String
Dim outVal As String
Dim commaPos As Integer
' Copy from column A to column B.'
fromCol = "A"
toCol = "B"
fromRow = "1"
toRow = "1"
' Go until no more entries in column A.'
inVal = Range(fromCol + fromRow).Value
While inVal <> ""
' Go until all sub-entries used up.'
While inVal <> ""
Range(fromCol + fromRow).Select
' Extract each subentry.'
commaPos = InStr(1, inVal, ",")
While commaPos <> 0
' and write to output column.'
outVal = Left(inVal, commaPos - 1)
Range(toCol + toRow).Select
Range(toCol + toRow).Value = outVal
toRow = Mid(Str(Val(toRow) + 1), 2)
' Remove that sub-entry.'
inVal = Mid(inVal, commaPos + 1)
While Left(inVal, 1) = " "
inVal = Mid(inVal, 2)
Wend
commaPos = InStr(1, inVal, ",")
Wend
' Get last sub-entry (or full entry if no commas).'
Range(toCol + toRow).Select
Range(toCol + toRow).Value = inVal
toRow = Mid(Str(Val(toRow) + 1), 2)
inVal = ""
Wend
' Advance to next source row.'
fromRow = Mid(Str(Val(fromRow) + 1), 2)
Range(fromCol + fromRow).Select
inVal = Range(fromCol + fromRow).Value
Wend
End Sub