Rearrange multiple columns in four columns, VBA

Attach a sample workbook (not image).

Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate.

Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and then scroll down to Manage Attachments to open the upload window.

Thank you so much for getting back to me so quickly! I attached an excel file with a BEFORE and AFTER sheet.

Sub tableS2Columns()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim inRng As Range

Set ws1 = Worksheets("Before")  'Input file
Set ws2 = Worksheets("After")   'Output file

Application.ScreenUpdating = False

lc = ws1.Cells(3, Columns.Count).End(xlToLeft).Column ' column count on input file

lr2 = 1                               ' Initial output eow
ws2.Range("A1:d10000").ClearContents  ' Clear output area

With ws1

For c = 1 To lc Step 4  ' Loop in blocks of 4 columns

    lr1 = ws1.Cells(Rows.Count, c).End(xlUp).Row         ' Find last row in current block
    Set inRng = .Range(.Cells(1, c), .Cells(lr1, c + 3)) ' get data in this block
    inRng.Copy Destination:=ws2.Cells(lr2, "A")          ' write data to columns A:C in output
    lr2 = lr2 + lr1                                      ' increment row for next addition
    
Next c

End With

Application.ScreenUpdating = True

End Sub

Click "RUN" on "After"

Thank you! This is impressive. I do get the following message/error though:

Run-time error '1004:
You can't paste this here because the Copy area and paste are aren't the same size.

Select just one cell in the paste area or an area that's the same size, and try pasting again.

What to I need to change in the following row: inRng.Copy Destination:=ws2.Cells(lr2, "A") ?

sub test()
Dim r as range
Dim v
set r = range("A1:D"&[A5000].end(3).row)
For each v in array("e","i","m")
Cells(1,v).value = r.value
Next v
End sub

Post file with errors as I don't know why the areas are not the same. Are there merged cells somewhere?

nRng.Copy Destination:=ws2.Cells(lr2, "A")

.... where ?

If you want to start in column other than "A" then change "A" to required column .

Lesson here: post a file that represent what the real outcome required is.

I believe I know what the problem might be. My data set is simply too large. The data for approximately 80% of my sample companies is rearranged perfectly using your code (the data reached the maximum of 1,048,576 rows). I will try to use a smaller data set. Thank you so much for your help, John!

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

EDIT: it should possible to split the into more than one sheet: is that acceptable?