A few words of thanks would be greatly appreciated.

Excel - Copy row and insert n times


I am trying to create a macro under Excel.

My data is as follows:

Column1 Column2 Column3 Column4
Data1 Data1 Name1;Name2;Name3 Data1
Data2 Data2 Name1;Name2;Data2
Data3 Data3 Name1;Name2;Name3 Data3

Each cell in column 3 contains n number of names separated with a semicolon.

I need a macro that does these things:

1) Create n number of rows after the first row. N is the number of names in the cell in the first of column 3.

2) Separate the names in the rows below. (Similar to Text to Columns)

3) Copy the content of the other cells in the original row to the inserted rows below.

4) Proceed to the next row and do it all again.

The outcome should look like this:

Column1 Column2 Column3 Column4
Data1 Data1 Name1 Data1
Data1 Data1 Name2 Data1
Data1 Data1 Name3 Data1

Data2 Data2 Name1 Data2
Data2 Data2 Name2 Data2

Data3 Data3 Name1 Data3
Data3 Data3 Name2 Data3
Data3 Data3 Name3 Data3

Can you help me out?


Download the file "duffy.xlsm" from this webpage http://ww1.speedy.sh.

The main data is in sheet 1 (without semicolons) and the result is in sheet2.

The macros are repeated here:

Sub test()
    Dim rrow1 As Range, rrow2 As Range, crow2 As String, rcol As Range
    Dim j As Long, k As Long, nname() As String
    Dim m As Integer, dest As Range, ddata() As String, n As Long
    Application.ScreenUpdating = False
    With Worksheets("sheet1")
        j = .Range("a1").End(xlDown).Row
        ReDim ddata(1 To j - 1)
        For k = 2 To j
            ddata(k - 1) = .Cells(k, Columns.Count).End(xlToLeft).Value
            'msgbox ddata(k - 1)
            Set rcol = Range(.Cells(k, "C"), .Cells(k, "c").End(xlToRight).Offset(0, -1))
            'msgbox rcol.Address
            m = WorksheetFunction.CountA(rcol)
            'msgbox m
            ReDim nname(1 To m)
            For n = 1 To m
                nname(n) = rcol(1, n)
                'msgbox nname(n)
            Next n
            'msgbox rcol.Address
            Range(.Cells(k, "A"), .Cells(k, "B")).Copy
            With Worksheets("sheet2")
                Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                'msgbox dest.Address
                Range(dest, dest.Offset(m - 1, 0)).PasteSpecial
                For n = 1 To m
                    dest.Offset(n - 1, 0).Offset(0, 2) = nname(n)
                    .Cells(dest.Offset(n - 1, 0).Row, Columns.Count).End(xlToLeft).Offset(0, 1) = ddata(k - 1)
                Next n
            End With
        Next k
    End With
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "macro over"
End Sub

Sub undo()
End Sub

Thanks to venkat1926 for this tip.


A few words of thanks would be greatly appreciated.

Ask a question
CCM is a leading international tech website. Our content is written in collaboration with IT experts, under the direction of Jean-François Pillou, founder of CCM.net. CCM reaches more than 50 million unique visitors per month and is available in 11 languages.
This document, titled « Excel - Copy row and insert n times », is available under the Creative Commons license. Any copy, reuse, or modification of the content should be sufficiently credited to CCM (ccm.net).