VBA copy set amount of rows into forms until end of data set

[willow1985]

I need help with writing a macro that can copy a set amount of rows (say 15 rows) from a table of data and paste the data into another sheet (forms) at set locations one after another until there is no more data to copy in the table.

I do not know what the max amount of rows/data that will be in the table or how many forms will be required, but I do know the form will repeat every 17 rows. See below example.

I hope someone can help me with this. Loop codes are not my strong suit.
Thank you!

Book1
	A	B	C	D	E	F	G
1	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
2	6-Jan-21	East	Jones	Pencil	95	1.99	189.05
3	23-Jan-21	Central	Kivell	Binder	50	19.99	999.5
4	9-Feb-21	Central	Jardine	Pencil	36	4.99	179.64
5	26-Feb-21	Central	Gill	Pen	27	19.99	539.73
6	15-Mar-21	West	Sorvino	Pencil	56	2.99	167.44
7	1-Apr-21	East	Jones	Binder	60	4.99	299.4
8	18-Apr-21	Central	Andrews	Pencil	75	1.99	149.25
9	5-May-21	Central	Jardine	Pencil	90	4.99	449.1
10	22-May-21	West	Thompson	Pencil	32	1.99	63.68
11	8-Jun-21	East	Jones	Binder	60	8.99	539.4
12	25-Jun-21	Central	Morgan	Pencil	90	4.99	449.1
13	12-Jul-21	East	Howard	Binder	29	1.99	57.71
14	29-Jul-21	East	Parent	Binder	81	19.99	1619.19
15	15-Aug-21	East	Jones	Pencil	35	4.99	174.65
16	1-Sep-21	Central	Smith	Desk	2	125	250
17	18-Sep-21	East	Jones	Pen Set	16	15.99	255.84
18	5-Oct-21	Central	Morgan	Binder	28	8.99	251.72
19	22-Oct-21	East	Jones	Pen	64	8.99	575.36
20	8-Nov-21	East	Parent	Pen	15	19.99	299.85
21	25-Nov-21	Central	Kivell	Pen Set	96	4.99	479.04
22	12-Dec-21	Central	Smith	Pencil	67	1.29	86.43
23	29-Dec-21	East	Parent	Pen Set	74	15.99	1183.26
24	15-Jan-22	Central	Gill	Binder	46	8.99	413.54
25	1-Feb-22	Central	Smith	Binder	87	15	1305
26	18-Feb-22	East	Jones	Binder	4	4.99	19.96
27	7-Mar-22	West	Sorvino	Binder	7	19.99	139.93
28	24-Mar-22	Central	Jardine	Pen Set	50	4.99	249.5
29	10-Apr-22	Central	Andrews	Pencil	66	1.99	131.34
30	27-Apr-22	East	Howard	Pen	96	4.99	479.04
31	14-May-22	Central	Gill	Pencil	53	1.29	68.37
32	31-May-22	Central	Gill	Binder	80	8.99	719.2
33	17-Jun-22	Central	Kivell	Desk	5	125	625
34	4-Jul-22	East	Jones	Pen Set	62	4.99	309.38
35	21-Jul-22	Central	Morgan	Pen Set	55	12.49	686.95
36	7-Aug-22	Central	Kivell	Pen Set	42	23.95	1005.9
37	24-Aug-22	West	Sorvino	Desk	3	275	825
38	10-Sep-22	Central	Gill	Pencil	7	1.29	9.03
39	27-Sep-22	West	Sorvino	Pen	76	1.99	151.24
40	14-Oct-22	West	Thompson	Binder	57	19.99	1139.43
41	31-Oct-22	Central	Andrews	Pencil	14	1.29	18.06
42	17-Nov-22	Central	Jardine	Binder	11	4.99	54.89
43	4-Dec-22	Central	Jardine	Binder	94	19.99	1879.06
44	21-Dec-22	Central	Andrews	Binder	28	4.99	139.72
Data

Book1
	A	B	C	D	E	F	G
1	CENTRAL FORM
2	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
3	23-Jan-21	Central	Kivell	Binder	50	19.99	999.5
4	9-Feb-21	Central	Jardine	Pencil	36	4.99	179.64
5	26-Feb-21	Central	Gill	Pen	27	19.99	539.73
6	18-Apr-21	Central	Andrews	Pencil	75	1.99	149.25
7	5-May-21	Central	Jardine	Pencil	90	4.99	449.1
8	25-Jun-21	Central	Morgan	Pencil	90	4.99	449.1
9	1-Sep-21	Central	Smith	Desk	2	125	250
10	5-Oct-21	Central	Morgan	Binder	28	8.99	251.72
11	25-Nov-21	Central	Kivell	Pen Set	96	4.99	479.04
12	12-Dec-21	Central	Smith	Pencil	67	1.29	86.43
13	15-Jan-22	Central	Gill	Binder	46	8.99	413.54
14	1-Feb-22	Central	Smith	Binder	87	15	1305
15	24-Mar-22	Central	Jardine	Pen Set	50	4.99	249.5
16	10-Apr-22	Central	Andrews	Pencil	66	1.99	131.34
17	14-May-22	Central	Gill	Pencil	53	1.29	68.37
18	Company Name
19	CENTRAL FORM
20	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
21	31-May-22	Central	Gill	Binder	80	8.99	719.2
22	17-Jun-22	Central	Kivell	Desk	5	125	625
23	21-Jul-22	Central	Morgan	Pen Set	55	12.49	686.95
24	7-Aug-22	Central	Kivell	Pen Set	42	23.95	1005.9
25	10-Sep-22	Central	Gill	Pencil	7	1.29	9.03
26	31-Oct-22	Central	Andrews	Pencil	14	1.29	18.06
27	17-Nov-22	Central	Jardine	Binder	11	4.99	54.89
28	4-Dec-22	Central	Jardine	Binder	94	19.99	1879.06
29	21-Dec-22	Central	Andrews	Binder	28	4.99	139.72
30
31
32
33
34
35
36	Company Name
37	CENTRAL FORM
38	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54	Company Name
55	CENTRAL FORM
56	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72	Company Name
Central Form

Sub Macro3()
'
' Macro3 Macro
'

'
    ActiveSheet.ListObjects("Order_Data").Range.AutoFilter Field:=2, Criteria1:= _
        "Central"
    Range("A3:G31").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Central Form").Select
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Data").Select
    Range("A32:G44").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Central Form").Select
    Range("A21").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

 

[willow1985]

Your filtering had to something to do with the 7 chunks only. The chunk is defined by the variable chunkSize in the code. Try this on a copy.

Sub PasteToCentralForm3()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant, Result() As Variant
    Dim numRows As Long, numCols As Long
    Dim i As Long, j As Long, loopCount As Long
    Dim chunkSize As Long
   
    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Table1").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 15 'adjust chunk size as needed.
   
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count

    p = 1
    ' Read data into array
    tableArray = tableRange.Value
    ReDim Result(1 To numRows, 1 To numCols)
    For m = 1 To numRows
        If tableArray(m, 2) = "Central" Then
            For n = 1 To numCols
                Result(p, n) = tableArray(m, n)
            Next n
             p = p + 1
        End If
    Next m
   
    Application.ScreenUpdating = False
    loopCount = WorksheetFunction.RoundUp(UBound(Result, 1) / chunkSize, 0)
   
    ' Collect all data into one large array
    Dim outputData() As Variant
    ReDim outputData(1 To loopCount * (chunkSize + 2) - 2, 1 To numCols)
   
    Dim outputIndex As Long
    outputIndex = 1
   
    For i = 1 To loopCount
        Dim outputRowCount As Long
        outputRowCount = WorksheetFunction.Min(chunkSize, numRows - (i - 1) * chunkSize)
        For j = 1 To outputRowCount
            For k = 1 To numCols
                outputData(outputIndex, k) = Result((i - 1) * chunkSize + j, k)
            Next k
            outputIndex = outputIndex + 1
        Next j
        outputIndex = outputIndex + 2 ' Skip two rows for each chunk
    Next i
   
    ' Output all data to destination sheet at once
    destSheet.Cells(3, 1).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
   
    Application.ScreenUpdating = True
End Sub

This code is very close! The only problem is it clears out the rows in the forms it is supposed to skip! I will show you a before and after screenshot of the results.
Is there a way to prevent it from clearing it?

Before:

After:

 

[willow1985]

Your filtering had to something to do with the 7 chunks only. The chunk is defined by the variable chunkSize in the code. Try this on a copy.

Sub PasteToCentralForm3()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant, Result() As Variant
    Dim numRows As Long, numCols As Long
    Dim i As Long, j As Long, loopCount As Long
    Dim chunkSize As Long
   
    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Table1").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 15 'adjust chunk size as needed.
   
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count

    p = 1
    ' Read data into array
    tableArray = tableRange.Value
    ReDim Result(1 To numRows, 1 To numCols)
    For m = 1 To numRows
        If tableArray(m, 2) = "Central" Then
            For n = 1 To numCols
                Result(p, n) = tableArray(m, n)
            Next n
             p = p + 1
        End If
    Next m
   
    Application.ScreenUpdating = False
    loopCount = WorksheetFunction.RoundUp(UBound(Result, 1) / chunkSize, 0)
   
    ' Collect all data into one large array
    Dim outputData() As Variant
    ReDim outputData(1 To loopCount * (chunkSize + 2) - 2, 1 To numCols)
   
    Dim outputIndex As Long
    outputIndex = 1
   
    For i = 1 To loopCount
        Dim outputRowCount As Long
        outputRowCount = WorksheetFunction.Min(chunkSize, numRows - (i - 1) * chunkSize)
        For j = 1 To outputRowCount
            For k = 1 To numCols
                outputData(outputIndex, k) = Result((i - 1) * chunkSize + j, k)
            Next k
            outputIndex = outputIndex + 1
        Next j
        outputIndex = outputIndex + 2 ' Skip two rows for each chunk
    Next i
   
    ' Output all data to destination sheet at once
    destSheet.Cells(3, 1).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
   
    Application.ScreenUpdating = True
End Sub

This code worked however when it skipped 2 rows it also cleared them (see before and after screenshots below)
Is there a way to not have them cleared?
Also is it possible to specify specific columns to copy only (Like A:C for example on this line: numCols = tableRange.Columns.Count)

Thank you so much for all of the help!

Before code:

After code (red circle data was cleared):

 

[willow1985]

Your filtering had to something to do with the 7 chunks only. The chunk is defined by the variable chunkSize in the code. Try this on a copy.

Sub PasteToCentralForm3()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant, Result() As Variant
    Dim numRows As Long, numCols As Long
    Dim i As Long, j As Long, loopCount As Long
    Dim chunkSize As Long
   
    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Table1").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 15 'adjust chunk size as needed.
   
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count

    p = 1
    ' Read data into array
    tableArray = tableRange.Value
    ReDim Result(1 To numRows, 1 To numCols)
    For m = 1 To numRows
        If tableArray(m, 2) = "Central" Then
            For n = 1 To numCols
                Result(p, n) = tableArray(m, n)
            Next n
             p = p + 1
        End If
    Next m
   
    Application.ScreenUpdating = False
    loopCount = WorksheetFunction.RoundUp(UBound(Result, 1) / chunkSize, 0)
   
    ' Collect all data into one large array
    Dim outputData() As Variant
    ReDim outputData(1 To loopCount * (chunkSize + 2) - 2, 1 To numCols)
   
    Dim outputIndex As Long
    outputIndex = 1
   
    For i = 1 To loopCount
        Dim outputRowCount As Long
        outputRowCount = WorksheetFunction.Min(chunkSize, numRows - (i - 1) * chunkSize)
        For j = 1 To outputRowCount
            For k = 1 To numCols
                outputData(outputIndex, k) = Result((i - 1) * chunkSize + j, k)
            Next k
            outputIndex = outputIndex + 1
        Next j
        outputIndex = outputIndex + 2 ' Skip two rows for each chunk
    Next i
   
    ' Output all data to destination sheet at once
    destSheet.Cells(3, 1).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
   
    Application.ScreenUpdating = True
End Sub

Please also explain the part of the code I listed below. When I apply this code to another data set I get a Runtime Error 9: Script out of Range on line:
outputData(outputIndex, k) = Result((i - 1) * chunkSize + j, k)

I am trying desperately to understand this part so I can make adjustments. I changed the skip 3 rows to 13 and Output cell to destSheet.Cells (13,1) 'First column, 13th row??
Thank you

' Collect all data into one large array
    Dim outputData() As Variant
    ReDim outputData(1 To loopCount * (chunkSize + 2) - 2, 1 To numCols)
    
    Dim outputIndex As Long
    outputIndex = 1
    
    For i = 1 To loopCount
        Dim outputRowCount As Long
        outputRowCount = WorksheetFunction.Min(chunkSize, numRows - (i - 1) * chunkSize)
        For j = 1 To outputRowCount
            For k = 1 To numCols
                outputData(outputIndex, k) = Result((i - 1) * chunkSize + j, k)
            Next k
            outputIndex = outputIndex + 1
        Next j
        outputIndex = outputIndex + 2 ' Skip two rows for each chunk
    Next i
    
    ' Output all data to destination sheet at once
    destSheet.Cells(3, 1).Resize(UBound(outputData, 1), UBound(outputData, 2)).Value = outputData
    
    Application.ScreenUpdating = True
End Sub

 

[Cubist]

The 2's here are the number of rows to skip. maybe make a variable.

ReDim outputData(1 To loopCount * (chunkSize + 2) - 2, 1 To numCols)

Here as well

outputIndex = outputIndex + 2 ' Skip two rows for each chunk

Edit: I haven't had time to look at your previous questions about the Headers get overriden.

 

[Cubist]

This seems to be working on my end. Adjusted for chunkSize = 13, rowSkip = 3 Try this.

Sub PasteToCentralForm4()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant, Result() As Variant
    Dim numRows As Long, numCols As Long
    Dim i As Long, j As Long, loopCount As Long
    Dim chunkSize As Long
    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Table1").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 13 'adjust chunk size as needed.
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count
    p = 1
   
    ' Read data into array
    tableArray = tableRange.Value
    ReDim Result(1 To numRows, 1 To numCols)
    For m = 1 To numRows
        If tableArray(m, 2) = "Central" Then
            For n = 1 To numCols
                Result(p, n) = tableArray(m, n)
            Next n
            p = p + 1
        End If
    Next m
   
    Application.ScreenUpdating = False
    loopCount = WorksheetFunction.RoundUp(UBound(Result, 1) / chunkSize, 0)
    Dim outputIndex As Long
    Dim rowSkip As Long
    rowSkip = 3 'change # of rows to skip
    outputIndex = 1
   
    ' Output each chunk of data
    For i = 1 To loopCount
        Dim outputRowCount As Long
        outputRowCount = WorksheetFunction.Min(chunkSize, numRows - (i - 1) * chunkSize)
        Dim outputData() As Variant
        ReDim outputData(1 To outputRowCount, 1 To numCols)
        For j = 1 To outputRowCount
            For k = 1 To numCols
                outputData(j, k) = Result((i - 1) * chunkSize + j, k)
            Next k
        Next j
        ' Output the chunk to destination sheet
        destSheet.Cells(outputIndex + 2, 1).Resize(outputRowCount, numCols).Value = outputData
        outputIndex = outputIndex + outputRowCount + rowSkip ' Move to next chunk
    Next i
    Application.ScreenUpdating = True
End Sub

 

[willow1985]

This seems to be working on my end. Adjusted for chunkSize = 13, rowSkip = 3 Try this.

Sub PasteToCentralForm4()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant, Result() As Variant
    Dim numRows As Long, numCols As Long
    Dim i As Long, j As Long, loopCount As Long
    Dim chunkSize As Long
    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Table1").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 13 'adjust chunk size as needed.
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count
    p = 1
  
    ' Read data into array
    tableArray = tableRange.Value
    ReDim Result(1 To numRows, 1 To numCols)
    For m = 1 To numRows
        If tableArray(m, 2) = "Central" Then
            For n = 1 To numCols
                Result(p, n) = tableArray(m, n)
            Next n
            p = p + 1
        End If
    Next m
  
    Application.ScreenUpdating = False
    loopCount = WorksheetFunction.RoundUp(UBound(Result, 1) / chunkSize, 0)
    Dim outputIndex As Long
    Dim rowSkip As Long
    rowSkip = 3 'change # of rows to skip
    outputIndex = 1
  
    ' Output each chunk of data
    For i = 1 To loopCount
        Dim outputRowCount As Long
        outputRowCount = WorksheetFunction.Min(chunkSize, numRows - (i - 1) * chunkSize)
        Dim outputData() As Variant
        ReDim outputData(1 To outputRowCount, 1 To numCols)
        For j = 1 To outputRowCount
            For k = 1 To numCols
                outputData(j, k) = Result((i - 1) * chunkSize + j, k)
            Next k
        Next j
        ' Output the chunk to destination sheet
        destSheet.Cells(outputIndex + 2, 1).Resize(outputRowCount, numCols).Value = outputData
        outputIndex = outputIndex + outputRowCount + rowSkip ' Move to next chunk
    Next i
    Application.ScreenUpdating = True
End Sub

5 out of 6 spreadsheets work with this code without clearing rows, so no idea why one of them is doing it. But code seems to be working perfectly!

Thank you very much for all of your help and explaining everything so thoroughly!