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

 

[mse330]

Hi,

Do you need the data to be split by "Region" ? i.e. Central first 15 row, then central 2nd 15 rows then East first 15 rows ... etc. ? All regions shall be in the same sheet "Central Form" ?

 

[willow1985]

Hi,

Do you need the data to be split by "Region" ? i.e. Central first 15 row, then central 2nd 15 rows then East first 15 rows ... etc. ? All regions shall be in the same sheet "Central Form" ?

There will be a separate sheet for each form: East Form, West Form and Central Form.
Currently I am just focusing on Central form to figure out the logistics.
My biggest issue is when I filter the data by Central, how can I (in VBA) count the first 15 visible cells, copy and paste them into the form, then go back to the data, grab the next set of 15 and so on. **Grabbing the filtered visible data in 15 row blocks until there are no results left is what has me stumped.

Thank you so much for your help!

 

[Cubist]

Try this on a copy.

Sub PasteToCentralForm()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant
    Dim numRows As Integer, numCols As Integer
    Dim i As Integer, j As Integer, loopCount As Integer

    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Table1").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 15
    
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count
    loopCount = WorksheetFunction.RoundUp(numRows / chunkSize, 0)
    
    Dim firstCell As Range
    Set firstCell = tableRange.Cells(1, 1)
    
    Application.ScreenUpdating = False
    For i = 0 To loopCount - 1
        firstCell.Offset(i * chunkSize).Resize(chunkSize, numCols).Copy
        destSheet.Range("A1").Offset(i * (chunkSize + 2) + 2).PasteSpecial xlPasteAll
    Next i
    Application.ScreenUpdating = True

End Sub

 

[Cubist]

This is considerably faster if you have a large table.

Sub PasteToCentralForm2()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() 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
    
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count
    loopCount = WorksheetFunction.RoundUp(numRows / chunkSize, 0)
    
    ' Read data into array
    tableArray = tableRange.Value
    
    Application.ScreenUpdating = False
    ' Clear previous data in destination sheet
    destSheet.Range("A1").CurrentRegion.Clear
    
    ' 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) = tableArray((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

 

[mse330]

Try below code ...

Sub Test()

Application.ScreenUpdating = False

Dim a, ws As Worksheet, Lr&
Set ws = Sheets("Data")
a = ws.[A1].CurrentRegion

With CreateObject("scripting.dictionary")
    For x = 2 To UBound(a)
        If Not .exists(a(x, 2)) Then
            .Add a(x, 2), Nothing
            If Not Evaluate("isref('" & a(x, 2) & "'!a1)") Then
                Sheets.Add(, Sheets(Sheets.Count)).Name = a(x, 2)
            Else
                Sheets(a(x, 2)).UsedRange.Clear
            End If
            ws.[K2] = "=""" & a(x, 2) & """=B2"
            ws.[A1].CurrentRegion.AdvancedFilter 2, ws.[K1:K2], Sheets(a(x, 2)).[A1]
            ws.[K2].Clear
            With Sheets(a(x, 2))
                With .UsedRange
                    .Interior.Color = xlNone
                    .Borders.LineStyle = xlNone
                    .Font.Bold = False
                End With
                Lr = .Range("A" & Rows.Count).End(3).Row
                For y = 2 To Lr Step 18
                    .Rows(y).Resize(3).Insert
                    With .Cells(y, 1)
                        .Value = "Company Name": .Resize(, 7).HorizontalAlignment = 7
                        .Offset(1) = a(x, 2) & " Form": .Offset(1).Resize(, 7).HorizontalAlignment = 7
                        .Offset(2).Resize(, 7) = [{"OrderDate","Region","Rep","Item","Units","Unit Cost","Total"}]
                        .Resize(3, 7).Font.Bold = True
                    End With
                Next
                .Rows(1).EntireRow.Delete
            End With
        End If
    Next
End With

End Sub

 

[willow1985]

Try this on a copy.

Sub PasteToCentralForm()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant
    Dim numRows As Integer, numCols As Integer
    Dim i As Integer, j As Integer, loopCount As Integer

    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Table1").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 15
 
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count
    loopCount = WorksheetFunction.RoundUp(numRows / chunkSize, 0)
 
    Dim firstCell As Range
    Set firstCell = tableRange.Cells(1, 1)
 
    Application.ScreenUpdating = False
    For i = 0 To loopCount - 1
        firstCell.Offset(i * chunkSize).Resize(chunkSize, numCols).Copy
        destSheet.Range("A1").Offset(i * (chunkSize + 2) + 2).PasteSpecial xlPasteAll
    Next i
    Application.ScreenUpdating = True

End Sub

This code was the closest but it only does in 7 row chunks. I had to add in a filter code so it grabs only "Central".
Is there a reason it is only copying the data in 7 row chunks? Is there a way to fix this?

Here is my modified version but don't know how to fix the 7 row only thing...

Sub PasteToCentralForm()
    Dim tableRange As Range, destSheet As Worksheet
    Dim tableArray() As Variant
    Dim numRows As Integer, numCols As Integer
    Dim i As Integer, j As Integer, loopCount As Integer

    Set tableRange = ThisWorkbook.Sheets("Data").ListObjects("Order_Data").DataBodyRange 'Change table name as needed
    Set destSheet = ThisWorkbook.Sheets("Central Form")
    chunkSize = 15
  
    numRows = tableRange.Rows.Count
    numCols = tableRange.Columns.Count
    loopCount = WorksheetFunction.RoundUp(numRows / chunkSize, 0)
  
        ThisWorkbook.Sheets("Data").ListObjects("Order_Data").Range.AutoFilter Field:=2, Criteria1:= _
        "Central"
  
    Dim firstCell As Range
    Set firstCell = tableRange.Cells(1, 1)
  
    Application.ScreenUpdating = False
    For i = 0 To loopCount - 1
        firstCell.Offset(i * chunkSize).Resize(chunkSize, numCols).Copy
        destSheet.Range("A1").Offset(i * (chunkSize + 2) + 2).PasteSpecial xlPasteValues
    Next i
    Application.ScreenUpdating = True

End Sub

Result of code:

VBA repeat form loop code template.xlsm
	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
11
12
13
14
15
16
17	Company Name
18	CENTRAL FORM
19	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
20	5-Oct-21	Central	Morgan	Binder	28	8.99	251.72
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	15-Jan-22	Central	Gill	Binder	46	8.99	413.54
24	1-Feb-22	Central	Smith	Binder	87	15	1305
25	24-Mar-22	Central	Jardine	Pen Set	50	4.99	249.5
26	10-Apr-22	Central	Andrews	Pencil	66	1.99	131.34
27	14-May-22	Central	Gill	Pencil	53	1.29	68.37
28
29
30
31
32
33
34	Company Name
35	CENTRAL FORM
36	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
37	31-May-22	Central	Gill	Binder	80	8.99	719.2
38	17-Jun-22	Central	Kivell	Desk	5	125	625
39	21-Jul-22	Central	Morgan	Pen Set	55	12.49	686.95
40	7-Aug-22	Central	Kivell	Pen Set	42	23.95	1005.9
41	10-Sep-22	Central	Gill	Pencil	7	1.29	9.03
42	31-Oct-22	Central	Andrews	Pencil	14	1.29	18.06
43	17-Nov-22	Central	Jardine	Binder	11	4.99	54.89
44	4-Dec-22	Central	Jardine	Binder	94	19.99	1879.06
45	21-Dec-22	Central	Andrews	Binder	28	4.99	139.72
46
47
48
49
50
51	Company Name
52	CENTRAL FORM
53	OrderDate	Region	Rep	Item	Units	Unit Cost	Total
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68	Company Name
Central Form

 

[Cubist]

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

 

[mse330]

@willow1985 Have you tried the code in post #6 ? Does it produce the final expected results ?

 

[willow1985]

@willow1985 Have you tried the code in post #6 ? Does it produce the final expected results ?

#6 Created separate spreadsheets instead of using the existing forms, which would not work for what I require unfortunately. But I appreciate the help!