Macro to split data into multiple cells

Hi All,

I need some help on a macro.
I have multiple entries in column C which I would like to split it up and show in multiple cells based on Column A& Column B. For example as below

Original
Column A Column B Column C
A 13.05.07 1,2,4,5
B 15.08.09 9,8,7,6


Output
Column A Column B Column C
A 13.05.07 1
A 13.05.07 2
A 13.05.07 4
A 13.05.07 5

Any idea anyone able to help me on this? Have attached the sample in tab Sample and how it should be in tab Output.
Hope someone is able to help me out. :-)

Kind Regards,
Mark.

Originally Posted by alansidman

Try this:

Option Explicit

Sub mark888()
    Application.ScreenUpdating = False
    Dim i As Long, lr As Long, lc As Long, j As Long
    Dim lr2 As Long, s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Sample")
    Set s2 = Sheets("Output")
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    s1.Range("A1:C1").Copy s2.Range("A1")
    With s1
        .Range("C2:C" & lr).TextToColumns Destination:=Range("C2"), _
                                          DataType:=xlDelimited, _
                                          TextQualifier:=xlDoubleQuote, _
                                          Semicolon:=True
        For i = 2 To lr
            lc = .Cells(i, Columns.Count).End(xlToLeft).Column
            lr2 = s2.Range("C" & Rows.Count).End(xlUp).Row
            .Range("A" & i & ":B" & i).Copy s2.Range("A" & lr2 + 1)
            .Range(.Cells(i, 3), .Cells(i, lc)).Copy
            s2.Range("C" & lr2 + 1).PasteSpecial xlPasteAll, , , True
        Next i
        Application.CutCopyMode = False
    End With

    With s2
        lr2 = .Range("C" & Rows.Count).End(xlUp).Row
        For i = 3 To lr2
            If .Range("A" & i) = "" Then
                .Range("A" & i) = .Range("A" & i - 1)
                .Range("B" & i) = .Range("B" & i - 1)
            End If
        Next i
    End With
    Application.ScreenUpdating = True
    MsgBox "Task Completed"
End Sub

Hi Alan,

This works althought there seems to be some mismatch. For example the first record shows 40 in tab Sample but 43 in tab Output.
Manually i calculated it should show only 40 records.

Kind Regards,
MArk.

Originally Posted by mark888

Hi Alan,

This works althought there seems to be some mismatch. For example the first record shows 40 in tab Sample but 43 in tab Output.
Manually i calculated it should show only 40 records.

Kind Regards,
MArk.

Hi Alan,
Sorry i know what went wrong. It calculated the first 3 which I already had there in the first place. :-)

Kind Regards,
Mark.

Originally Posted by mark888

Hi Alan,

This works althought there seems to be some mismatch. For example the first record shows 40 in tab Sample but 43 in tab Output.
Manually i calculated it should show only 40 records.

Kind Regards,
MArk.

Hi Alan,
Sorry i know what went wrong. It calculated the first 3 which I already had there in the first place. :-)

Kind Regards,
Mark.

Originally Posted by millz

Try:

Sub a()
    Dim i As Long, j As Long, v, ws As Worksheet
    Set ws = ActiveSheet
    With Sheets.Add
        .Cells(1, 1).Resize(, 3).Value = ws.Cells(1, 1).Resize(, 3).Value
        For i = 2 To ws.Cells(rows.count, 3).End(xlUp).row
            v = Split(ws.Cells(i, 3).Value, ";")
            For j = LBound(v) To UBound(v)
                .Cells(rows.count, 1).End(xlUp).Offset(1).Resize(, 3).Value = Array(ws.Cells(i, 1).Value, ws.Cells(i, 2).Value, v(j))
            Next
        Next
    End With
End Sub

Hello Millz,

This works perfectly as well. Many thanks sir.

Kind Regards,
MArk.

try this:

Sub zz()
Dim ar As Variant, br(1 To 1048576, 1 To 3), i&, j&, k&, n%, t
ar = Sheets(1).[a1].CurrentRegion
For k = 2 To UBound(ar)
    t = Split(ar(k, 3), ";")
    For i = 0 To UBound(t)
       n = n + 1
       br(n, 1) = ar(k, 1)
       br(n, 2) = ar(k, 2)
       br(n, 3) = t(i)
    Next
Next
With Sheets(2)
    .Range("a2:c1048576").Clear
    .Range("a" & .[a1048576].End(3).Row + 1).Resize(n, 3) = br
End With
End Sub

Originally Posted by ikboy

try this:

Sub zz()
Dim ar As Variant, br(1 To 1048576, 1 To 3), i&, j&, k&, n%, t
ar = Sheets(1).[a1].CurrentRegion
For k = 2 To UBound(ar)
    t = Split(ar(k, 3), ";")
    For i = 0 To UBound(t)
       n = n + 1
       br(n, 1) = ar(k, 1)
       br(n, 2) = ar(k, 2)
       br(n, 3) = t(i)
    Next
Next
With Sheets(2)
    .Range("a2:c1048576").Clear
    .Range("a" & .[a1048576].End(3).Row + 1).Resize(n, 3) = br
End With
End Sub

Hi Ikboy,

This works perfectly as well. Many thanks all. :-)

Kind Regards,
Mark.