Merge three sheets to create three new sheets

[StuartR]

I can do this manually, but if there's an easy way to automate it then I would be grateful for any guidance.

I have a workbook with three worksheets. All sheets have identical layout.
Row 1 is headings
Rows 2 through 21 contain data

I need to create three new worksheets, either in the same workbook, or each as a separate workbook
The first new worksheet should contain
Row 1 from any of the original worksheets (this row is identical in all three)
Row 2 from the first original
Row 3 from the second original
Row 4 from the third original
Row 5 from the first
etc.

The second new worksheet should contain
Row 1 from any of the original worksheets
Row 2 from the second original
etc.

Eventually I will have three new worksheets with the data from the original three worksheets, but merged so that each new worksheet has 7 rows from two of the originals and 6 rows from the other

[HansV]

A macro:

Code: Select all

Sub Create3Sheets()
    Dim w As Worksheet
    Dim i As Long
    Dim j As Long
    Dim r As Long
    Dim c As Long
    Dim n As Long
    Dim v1, v2, v3, vo, vn
    Application.ScreenUpdating = False
    n = Worksheets(1).Cells(1, Worksheets(1).Columns.Count).End(xlToLeft).Column
    v1 = Worksheets(1).Range("A1").Resize(21, n).Value
    v2 = Worksheets(2).Range("A1").Resize(21, n).Value
    v3 = Worksheets(3).Range("A1").Resize(21, n).Value
    ReDim vo(1 To 21, 1 To n, 1 To 3)
    For r = 1 To 21
        For c = 1 To n
            vo(r, c, 1) = v1(r, c)
            vo(r, c, 2) = v2(r, c)
            vo(r, c, 3) = v3(r, c)
        Next c
    Next r
    ReDim vn(1 To 21, 1 To n)
    For i = 1 To 3
        Set w = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        For r = 1 To 21
            For c = 1 To n
                vn(r, c) = vo(r, c, (r + i) Mod 3 + 1)
            Next c
        Next r
        w.Range("A1").Resize(21, n).Value = vn
    Next i
    Application.ScreenUpdating = True
End Sub

[snb]

To illustrate the principle:

Code: Select all

Sub M_snb()
   sn = Sheet1.UsedRange
   sp = Sheet2.UsedRange
   sq = Sheet3.UsedRange
   
   ReDim st(20, UBound(sn, 2))
   
   For j = 0 To 2
     For jj = 0 To 20
       sv = Array(sn, sp, sq)((Abs(jj + j - 1)) Mod 3)
       For jjj = 1 To UBound(st, 2)
         st(jj, jjj) = sv(n + 1, jjj)
       Next
       n = n + 1
     Next
     
     Cells(30, 1).Offset(, j * 10).Resize(UBound(st) + 1, UBound(st, 2) + 1) = st
     ReDim st(20, UBound(sn, 2))
     n = 0
   Next
End Sub

[StuartR]

Thank you both so much for these almost instant and very helpful replies. I won't be able to test this for a day or so, as I still have to finish other work on one of the three worksheets. I will let you know the outcome by the weekend.

[StuartR]

Thank you. I used Hans code, and I just needed to add

Code: Select all

        For c = 1 To n
            w.Columns(c).ColumnWidth = Worksheets(1).Columns(c).ColumnWidth
        Next c

near the end to set all the column widths in the new sheets.

[StuartR]

To illustrate the principle:

Code: Select all

Sub M_snb()
   sn = Sheet1.UsedRange
   sp = Sheet2.UsedRange
   sq = Sheet3.UsedRange
   
   ReDim st(20, UBound(sn, 2))
   
   For j = 0 To 2
     For jj = 0 To 20
       sv = Array(sn, sp, sq)((Abs(jj + j - 1)) Mod 3)
       For jjj = 1 To UBound(st, 2)
         st(jj, jjj) = sv(n + 1, jjj)
       Next
       n = n + 1
     Next
     
     Cells(30, 1).Offset(, j * 10).Resize(UBound(st) + 1, UBound(st, 2) + 1) = st
     ReDim st(20, UBound(sn, 2))
     n = 0
   Next
End Sub

I read through this code a few times, but it's a bit beyond me to follow how it works! Can you please explain it for me.

[snb]

Did you check the result ?

See the attachment: F8 is your friend.