VBA复制来自不同范围的粘贴值，然后粘贴到同一张纸，同一行偏移列上（重复多张纸）

Question

我本来要作Case陈述，但在这种情况下我认为这不是很有意义，因为我是VBA n00b，因为此工作簿将保持静态，所以我不介意采用非最佳方法并记录一个我复制和粘贴的宏，但我想我先问过这里。

我在1个工作簿中有6个工作表。

Sheet1：复制BA17：BI31，复制BA48：BI50，复制BA67：BI81，复制BA98：BI100，复制BA117：BI131，复制BA148：BI150，复制BA167：BI181，复制BA198：BI200，复制BA215：BI215，复制BA230： BI230，复制BA246：BI260，复制BA275：BI277

并将以上副本粘贴到相同的行中，但是粘贴到同一张纸的AE：AM列中（仅偏移）。

如果有人可以为此指引我正确的方向，那么我可以对其他5张纸重复该解决方案，在该5张纸上，我必须做相同的想法，但行和列要不同。

任何帮助，将不胜感激，谢谢！

Sub CopyPasteOffetColumns()

Range("BA17:BI31").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE17").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA48:BI50").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE48").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA67:BI81").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE67").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA98:BI100").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE98").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA117:BI131").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE117").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA148:BI150").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE148").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA167:BI181").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE167").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA198:BI200").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE198").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA215:BI215").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE215").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA230:BI230").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE230").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA246:BI260").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE246").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("BA275:BI277").Select
Application.CutCopyMode = False
Selection.Copy
Range("AE275").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
End Sub

Answer 1

如下所示就足够了：

Sub CopyPasteOffetColumns()

Dim rng As Range

Set rng = Range("BA17:BI31")
With rng
    .Copy
    .Offset(0, -22).PasteSpecial (xlPasteValues)
End With

Set rng = Range("BA48:BI50")
With rng
    .Copy
    .Offset(0, -22).PasteSpecial (xlPasteValues)
End With

'Repeat for each range

End Sub

通常，如果您有条件选择要复制的行，则可以使用这样的代码使其更具动态性。 例如，如果您要复制BA列中的值等于“ 1234”的所有内容（这可以是我刚刚选择的一种简单标准），则下面的内容将遍历BA列并复制BA所在的所有行= 1234：

Sub CopyPasteOffetColumns()

Dim rng As Range, c As Range
Dim sh As Worksheet

Set sh = ActiveSheet

' Set the range to be the used cells in column BA (starting from BA1)
Set rng = Range("BA1:BA" & sh.Cells(sh.Rows.Count, "BA").End(xlUp).Row)

' Cycle through the cells and apply the criteria
For Each c In rng
    If c.Value = 1234 Then ' change criteria as required
        Range(c.AddressLocal, c.Offset(0, 8).AddressLocal).Copy
        c.Offset(0, -22).PasteSpecial xlPasteValues
    End If
Next c

End Sub