VBA Excel Loop Copy and Paste

Question

I am trying to loop a code so I do not have to manually type in the cell range every time.

Sub copy()

Dim x As Range
Dim y As Range
Set x = Range("C24361:F24363")
Set y = Range("P1")

x.copy
y.Select
ActiveSheet.Paste

x.Offset(5, 0).copy
y.Offset(3, 0).Select
ActiveSheet.Paste

x.Offset(10, 0).copy
y.Offset(6, 0).Select
ActiveSheet.Paste

x.Offset(15, 0).copy
y.Offset(9, 0).Select
ActiveSheet.Paste

x.Offset(54, 0).copy
y.Offset(12, 0).Select
ActiveSheet.Paste

x.Offset(59, 0).copy
y.Offset(15, 0).Select
ActiveSheet.Paste

x.Offset(64, 0).copy
y.Offset(18, 0).Select
ActiveSheet.Paste

x.Offset(69, 0).copy
y.Offset(21, 0).Select
ActiveSheet.Paste

x.Offset(108, 0).copy
y.Offset(24, 0).Select
ActiveSheet.Paste

x.Offset(113, 0).copy
y.Offset(27, 0).Select
ActiveSheet.Paste

x.Offset(118, 0).copy
y.Offset(30, 0).Select
ActiveSheet.Paste

x.Offset(123, 0).copy
y.Offset(33, 0).Select
ActiveSheet.Paste

x.Offset(162, 0).copy
y.Offset(36, 0).Select
ActiveSheet.Paste

x.Offset(167, 0).copy
y.Offset(39, 0).Select
ActiveSheet.Paste

x.Offset(172, 0).copy
y.Offset(42, 0).Select
ActiveSheet.Paste

x.Offset(177, 0).copy
y.Offset(45, 0).Select
ActiveSheet.Paste

End Sub

Right now I grab the range specified...and drop three copy..paste..etc..once 4 copies are made...I need to drop 54 and run the same drop 5 copy (so 59)..and continue the 3 drop for the paste...Any clues on how I can accomplish this task?

THANK YOU

slightly confused... so first it is 5,10,15,54 and then it is 5,10,15,59 or 10,15,20,59? — Siddharth Rout
Yeah. So It is a copy then move down 5,10,15, then 54 (these are separated by 5), so 59,64,69, then 108, 113, 118, 123, then 162 (+5+5 etc)..In English, there are 100s of 4 3x4 copies I need to make and the first cell of each set of 4 3x4s is separated by 54 cells for each city (hence the 54, 108, 162 to start). Make sense? Thank you — Colin
The 54 is to jump to the next set of 4 3x4s since the first cell is 54 away from the original copy I make (in this example C7). Also the reason it jumps five is the first cell for each 3x4 is 5 cells away. — Colin
So what comes after 5,10,15,54? Can you write a second set of copy paste code in yuor question above so that I can see what do you mean? — Siddharth Rout
I wrote a few more sets..so after copying the first 4 sets of 3x3 it jumps 54...then you see 3 more sets of 3x3..then 108...3 more sets...162 etc — Colin

paul bica paul bica · Accepted Answer · 2015-09-07T05:57:11

For sets:

Option Explicit

Sub copySets()
    Const ITERATIONS As Long = 5    'repeated sets of 4 ranges appended
    Const TOTAL_UNIT As Long = 4    'one unit contains 4 ranges
    Const RNG_OFFSET As Long = 2    'one range is 3 rows
    Const TB         As Long = 54   'offset between units

    Dim ws As Worksheet, rng As Range, rngRows As Long, setRows As Long, fSet As Range
    Dim cl1R As Long, cl1C As Long, cl2R As Long, cl2C As Long, i As Long, j As Long

    Set ws = ThisWorkbook.ActiveSheet
    With ws
        cl1R = 7:   cl1C = 3:   cl2R = 9:   cl2C = 6  'Range("C7") and Range("F9")
        Set rng = .Range(.Cells(cl1R, cl1C), .Cells(cl2R, cl2C))

        rngRows = cl2R - cl1R + 1       'rows in range unit
        setRows = rngRows + RNG_OFFSET  'rows in range unit + offset rows between units

        For i = 1 To ITERATIONS
            If fSet Is Nothing Then Set fSet = rng Else Set fSet = Union(fSet, rng)
            For j = 1 To TOTAL_UNIT - 1
                Set fSet = Union(fSet, rng.Offset(setRows * j, 0))
            Next
            Set rng = .Range(.Cells(cl1R + (TB * i), cl1C), .Cells(cl2R + (TB * i), cl2C))
        Next

        fSet.Copy .Cells(((rngRows * j) * i) - ((rngRows * TOTAL_UNIT) * i) + 1, 16)
    End With
End Sub

Test file:

Addition:

To copy cities:

Sub copyCities()
   Const CP As Long = 5    'copy-paste repeated (iterations)
   Const CC As Long = 2    'copy column (Col "B": cities)
   Const CO As Long = 54   'offset between copied cells (cities)
   Const PC As Long = 16   'paste column (Col "P" = 16)
   Const PO As Long = 12   'paste offset

   Dim i As Long

   With ThisWorkbook.ActiveSheet
    For i = 0 To CP - 1
     .Range(.Cells((i * PO) + 1, PC), .Cells((i * PO) + PO, PC)) = .Cells((CO * i) + 1, CC)
    Next
   End With
End Sub

VBA Excel Loop Copy and Paste

1 Answers