VBA Excel循环复制和粘贴

Question

我正在尝试循环代码，因此我不必每次都手动输入单元格区域。

副本（）

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

现在我抓住指定的范围...然后放下三个copy..paste..etc..once 4个副本...我需要删除54并运行相同的drop 5副本（所以59）。 。并继续下降3滴...有关如何完成此任务的任何线索？

谢谢你

Answer 1

对于集合：

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

测试文件：

<强>加成：

复制城市：

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