Excel VBA merge multiple columns into one on separate rows

Question

I have an excel 2007 worksheet open with 5 colums and +/-5000 rows of data.

What I want to do is create a macro that will:

insert 3 blank rows under each record
copy the value in that row on column 1 and paste it in the 3 new rows in column 1
CUT the value from column 3 and place it in the first blank row beneath it in column 2
CUT the value from column 4 and place it in the next blank row beneath it in column 2
CUT the value from column 5 and place it in the next blank row beneath it in column 2

I am pulling out my hair trying to accomplish this but to no avail! please could someone assist me with this?

Much thanks

Show us what you have done so we can help.

Raj More
– Raj More

2009-11-13 13:35:48 +00:00
Commented Nov 13, 2009 at 13:35 — Raj More
– Raj More, Commented Nov 13, 2009 at 13:35

Adriaan Stander · Accepted Answer · 2009-11-13 13:51:07Z

2

Try something like this

Sub Macro1()
Dim range As range
Dim i As Integer

Dim RowCount As Integer
Dim ColumnCount As Integer
Dim sheet As worksheet
Dim tempRange As range
Dim valueRange As range
Dim insertRange As range

    Set range = Selection
    RowCount = range.Rows.Count
    ColumnCount = range.Columns.Count
    For i = 1 To RowCount
        Set sheet = ActiveSheet

        Set valueRange = sheet.range("A" & (((i - 1) * 4) + 1), "E" & (((i - 1) * 4) + 1))

        Set tempRange = sheet.range("A" & (((i - 1) * 4) + 2), "E" & (((i - 1) * 4) + 2))
        tempRange.Select
        tempRange.Insert xlShiftDown
        Set insertRange = Selection
        insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
        insertRange.Cells(1, 2) = valueRange.Cells(1, 3)
        valueRange.Cells(1, 3) = ""

        Set tempRange = sheet.range("A" & (((i - 1) * 4) + 3), "E" & (((i - 1) * 4) + 3))
        tempRange.Select
        tempRange.Insert xlShiftDown
        Set insertRange = Selection
        insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
        insertRange.Cells(1, 2) = valueRange.Cells(1, 4)
        valueRange.Cells(1, 4) = ""

        Set tempRange = sheet.range("A" & (((i - 1) * 4) + 4), "E" & (((i - 1) * 4) + 4))
        tempRange.Select
        tempRange.Insert xlShiftDown
        Set insertRange = Selection
        insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
        insertRange.Cells(1, 2) = valueRange.Cells(1, 5)
        valueRange.Cells(1, 5) = ""

    Next i
End Sub

answered Nov 13, 2009 at 13:51

Adriaan Stander

167k32 gold badges294 silver badges288 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

Shalan Over a year ago

Umm...sorry I had forgotten this earlier and I'd hate to ask but how would you then insert an "entry number" in the 3rd column? Now that we have 4 rows for each original record, how would each of those recordsets show "1,2,3,4" ?? I tried modifying your code but botched it up a little :(

Shalan Over a year ago

Nevermind...got it working now! thnaks again for the assist!!

Joel Goodwin · Accepted Answer · 2009-11-13 13:48:09Z

2

Pass the worksheet to this particular function. It's not a complicated thing to do - I'd be interested to know what was going wrong with your approaches (it would have been good to post sample code in your question).

Public Sub splurge(ByVal sht As Worksheet)

    Dim rw As Long
    Dim i As Long

    For rw = sht.UsedRange.Rows.Count To 1 Step -1
        With sht
            Range(.Rows(rw + 1), .Rows(rw + 3)).Insert
            For i = 1 To 3
                ' copy column 1 into each new row
                .Cells(rw, 1).Copy .Cells(rw + i, 1)
                ' cut column 3,4,5 and paste to col 2 on next rows
                .Cells(rw, 2 + i).Cut .Cells(rw + i, 2)
            Next i
        End With
    Next rw

End Sub

answered Nov 13, 2009 at 13:48

Joel Goodwin

5,09629 silver badges30 bronze badges

1 Comment

Shalan Over a year ago

Hi Joel! sorry i didnt refresh the page so didnt see ur post. Thank u however for the effort. I will nonetheless try this out! thank u!

Fionnuala · Accepted Answer · 2009-11-13 13:37:02Z

1

How about:

Dim cn As Object
Dim rs As Object

strFile = Workbooks(1).FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon

strSQL = "SELECT t.F1, t.Col2 FROM (" _
       & "SELECT F1, 1 As Sort, F3 As Col2 FROM [Sheet1$] " _
       & "UNION ALL " _
       & "SELECT F1, 2 As Sort, F4 As Col2 FROM [Sheet1$] " _
       & "UNION ALL " _
       & "SELECT F1, 3 As Sort, F5 As Col2 FROM [Sheet1$] ) As t " _
       & "ORDER BY F1, Sort"

rs.Open strSQL, cn

Worksheets("Sheet6").Cells(2, 1).CopyFromRecordset rs

answered Nov 13, 2009 at 13:37

Fionnuala

91.4k7 gold badges121 silver badges155 bronze badges

3 Comments

Shalan Over a year ago

Hi Remou! same as with Joel above...didnt see these 2 additional posts. Thank u however for this, I've never seen SQL used in VBA before, so I'll try this out for curiousity! thank u!

Fionnuala Over a year ago

Two original posts :) Enjoy.

Shalan Over a year ago

:$ yeah i noticed the submission times now. but the strange thing is that Astander's answer was the ONLY one when I refreshed the screen ????? weird!

Collectives™ on Stack Overflow

Excel VBA merge multiple columns into one on separate rows

3 Answers 3

2 Comments

1 Comment

3 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

2 Comments

1 Comment

3 Comments

Your Answer

Sign up or log in

Post as a guest

Related