VBA Copy Paste Values From Separate Ranges And Paste On Same Sheet, Same Row Offset Columns (Repeat For Multiple Sheets)

问题

I was going to make a Case statement but I don't think that makes much sense in this situation, I'm a VBA n00b, since this workbook will remain quite static I don't mind taking the non-optimal approach and record a macro of me copying and pasting but I thought I'd ask here before I land on that.

I have 6 worksheets in 1 workbook.

Sheet1: Copy BA17:BI31, Copy BA48:BI50, Copy BA67:BI81, Copy BA98:BI100, Copy BA117:BI131, Copy BA148:BI150, Copy BA167:BI181, Copy BA198:BI200, Copy BA215:BI215, Copy BA230:BI230, Copy BA246:BI260, Copy BA275:BI277

And paste the above copies into the identical rows, however in columns AE:AM of the same sheet (simply offset).

If someone can steer me in the right direction for this I could repeat that solution for the other 5 sheets where I have to do the same idea but for different row and columns.

Any help would be appreciated, thanks!

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

回答1:

Something like the following would suffice:

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

Generally you would use code like this to make it more dynamic, if you have a criteria to select which rows to copy. For example if you want to copy everything where the value in column BA equals '1234' (this can be any kind of criteria I have just picked a nice simple one) then the below would cycle through column BA and copy all the rows where 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

来源：https://stackoverflow.com/questions/21869053/vba-copy-paste-values-from-separate-ranges-and-paste-on-same-sheet-same-row-off