Tente isso, mas altere os nomes das planilhas (ou seja, Sheet1 and Sheet2
) para as planilhas em sua pasta de trabalho. Observe que Sheet2
é uma planilha vazia cujo resultado desejado será armazenado nela.
Option Explicit
Dim wshI As Worksheet
Dim wshO As Worksheet
Dim i As Integer
Dim j As Integer
Dim r As Integer
Sub delimited()
Set wshI = Worksheets("Sheet1") 'change this to the sheet that has your data
Set wshO = Worksheets("Sheet2") 'make a new sheet and change this to its name
'This extract each size to a column (text to columns)
wshI.Activate
'Change "100" to the last column of your data
wshI.Range("C2:C100").TextToColumns Destination:=Range("C2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2)), TrailingMinusNumbers:= _
True
i = 1
j = 3
r = 1
'This put the desired outcome into the sheet2
While wshI.Cells(i, 1) <> ""
Do While wshI.Cells(i, j) <> ""
If j = 3 Then
wshO.Cells(r, 1) = wshI.Cells(i, 1)
wshO.Cells(r, 2) = wshI.Cells(i, 2)
wshO.Cells(r, 3) = wshI.Cells(i, 3)
Else
wshO.Cells(r, 3) = wshI.Cells(i, j)
End If
j = j + 1
r = r + 1
Loop
j = 3
i = i + 1
Wend
i = 2
j = 4
'This put the data into its original format
While wshI.Cells(i, 1) <> ""
Do While wshI.Cells(i, j) <> ""
wshI.Cells(i, 3) = wshI.Cells(i, 3) & ", " & wshI.Cells(i, j)
wshI.Cells(i, j).Clear
j = j + 1
Loop
j = 4
i = i + 1
Wend
End Sub