vba 如何将工作簿中的非连续单元格复制到另一个工作簿中的一组不同的非连续单元格？

How can I copy non-contiguous cells from a workbook to a different set of non-contiguous cells in another workbook?

提问by user3179945

I have a Master blank workbook that users copy, to record one year's worth of information. The Master blank allows the user to point to last year's 'old' workbook, insert the proper number of rows into the new to match the old, and then copy/paste two different contiguous ranges from the old into matching ranges in the "new" blank workbook.

我有一个用户复制的 Master 空白工作簿，用于记录一年的信息。主空白允许用户指向去年的“旧”工作簿，将适当数量的行插入新的以匹配旧的，然后将旧的两个不同的连续范围复制/粘贴到“新”中的匹配范围空白工作簿。

Now, I want it to copy the values that are the totals from non-contiguous columns on the old worksheet into different non-contiguous cells on the new worksheet.

现在，我希望它将旧工作表上非连续列的总计值复制到新工作表上的不同非连续单元格中。

The totals are on a different row for each user so I use a lastrow function to find the row number. But it seems I cannot use that in defining the non-contiguous ranges.

每个用户的总数位于不同的行上，因此我使用 lastrow 函数来查找行号。但似乎我不能在定义非连续范围时使用它。

All the code is included below. You will notice a section where I'm trying to copy all of the data from an old worksheet into the new worksheet using Union on ranges because it too is a bunch of non-contiguous cells, but it's not working either. If I get the first problem solved, I should be able to adapt it to the second problem.

所有代码都包含在下面。您会注意到有一个部分，我尝试在范围上使用 Union 将旧工作表中的所有数据复制到新工作表中，因为它也是一堆不连续的单元格，但它也不起作用。如果我解决了第一个问题，我应该能够适应第二个问题。

Edit:
I modified the "union" section and now all of the correct cells are being selected but Selection.Copyfails. What's the alternative?

编辑：
我修改了“联合”部分，现在所有正确的单元格都被选中但Selection.Copy失败了。什么是替代方案？

Edit #2:
I added two screenshots of the Master blank and a user's file. It is easy to see a) the number of rows is different and b) the shaded areas are the ones I wish to copy/paste (in the 'union' section of code). In the next pair of screenshots, the red and green cells of the user's file need to be imported into the corresponding red and green cells of the Master blank file.

编辑 #2：
我添加了主空白和用户文件的两个屏幕截图。很容易看出 a) 行数不同，b) 阴影区域是我希望复制/粘贴的区域（在代码的“联合”部分）。在接下来的一对截图中，需要将用户文件的红色和绿色单元格导入到Master空白文件的相应红色和绿色单元格中。

Option Explicit
Sub UpdateFromOld()

Dim fd As FileDialog
Dim NewWbk As Workbook, OldWbk As Workbook
Dim vrtSelectedItem As Variant, fname As Variant
Dim cella As Range, cellb As Range, cell1 As Range, cell2 As Range
Dim wsh As Worksheet, wsh2 As Worksheet
Dim WshName As String, WshName2 As String
Dim Answer1 As String, Answer2 As String
Dim UsedRange1 As Range, UsedRange2 As Range
Dim InputRange As Range, InputRange1 As Range, InputRange2 As Range, InputRange3 As Range, InputRange4 As Range, InputRange5 As Range
Dim InputRange6 As Range, InputRange7 As Range, InputRange8 As Range, InputRange9 As Range, InputRange10 As Range, InputRange11 As Range
Dim LstYr, ThisYr
Dim ExtraRows As Integer, RowCounter As Integer
Dim SumArray1(24)
Dim MyCell1, cell

On Error GoTo ErrorHandler

Range("B5").Select
WshName = InputBox("Type in your location name", "Annual Ad Planner")
Range("B5").Value = WshName
ActiveSheet.Name = WshName
Set wsh = Worksheets(WshName)

'Application.ScreenUpdating = False

'select the old file to update from
MsgBox "In the next window, navigate to and select the Ad Planner file you are updating from.", vbOKOnly, "Annual Ad Planner"
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    .Filters.Add "Previous Ad Planner", "*.xls", 1
    If .Show = -1 Then
        For Each vrtSelectedItem In .SelectedItems
            fname = vrtSelectedItem
        Next vrtSelectedItem
    Else
        MsgBox "You ended the update process.", vbOKOnly, "Annual Ad Planner"
        GoTo ErrorHandler
    End If
End With

Set OldWbk = Workbooks.Open(fname)
OldWbk.Unprotect
Set NewWbk = ThisWorkbook
NewWbk.Unprotect
Set fd = Nothing


NewWbk.Worksheets(WshName).Visible = True
NewWbk.Worksheets(WshName).Activate
NewWbk.Worksheets(WshName).Unprotect
Set cella = Cells(Rows.Count, "A").End(xlUp).Offset(0, 0)

OldWbk.Activate
Range("B5").Select
WshName2 = ActiveCell.Worksheet.Name
Set wsh2 = Worksheets(WshName2)
OldWbk.Worksheets(WshName2).Visible = True
OldWbk.Worksheets(WshName2).Activate
OldWbk.Worksheets(WshName2).Unprotect
Set cellb = Cells(Rows.Count, "B").End(xlUp).Offset(0, 0)

Range("B5").Select
Selection.Copy
NewWbk.Activate
Range("B5").Select
Range("B5").PasteSpecial xlPasteValues

Range("B23").Select
If cellb.Row > cella Then
    ExtraRows = cellb.Row - cella
    For RowCounter = 1 To ExtraRows
        AddRow
    Next RowCounter
End If
NewWbk.Unprotect
NewWbk.Worksheets(WshName).Unprotect

'Copy & Paste list of lead sources
OldWbk.Activate
Range("B20:B" & cellb.Row - 1).Select
Selection.Copy
NewWbk.Activate
Range("B20").Select
Range("B20").PasteSpecial xlPasteValues

'Copy & Paste classifications & segments
OldWbk.Activate
Range("CI20:CK" & cellb.Row - 1).Select
Selection.Copy
NewWbk.Activate
Range("CI20").Select
Range("CI20").PasteSpecial xlPasteValues
Application.CutCopyMode = False

Answer1 = MsgBox("Are you importing last year's file?", vbYesNoCancel, "Annual Ad Planner")
If Answer1 = vbNo Then
    Answer2 = MsgBox("Are you updating the 2014 file?", vbYesNoCancel, "Annual Ad Planner")
    If Answer2 = vbYes Then
        Set InputRange = Union(Range("C3"), Range("C4"), Range("C6"), Range("C7"), Range("C9"), Range("E6"), Range("E7"), Range("E9"), Range("J3"), Range("J4"), Range("J6"), Range("J7"), Range("J9"), Range("L6"), Range("L7"), Range("L9"), Range("Q3"), Range("Q4"), Range("Q6"), Range("Q7"), Range("Q9"), Range("S6"), Range("S7"), Range("S9"), Range("X3"), Range("X4"), Range("X6"), Range("X7"), Range("X9"), Range("Z6")) '30 ranges
        Set InputRange1 = Union(Range("Z7"), Range("Z9"), Range("AE3"), Range("AE4"), Range("AE6"), Range("AE7"), Range("AE9"), Range("AG6"), Range("AG7"), Range("AG9"), Range("AL3"), Range("AL4"), Range("AL6"), Range("AL7"), Range("AL9"), Range("AN6"), Range("AN7"), Range("AN9"), Range("AS3"), Range("AS4"), Range("AS6"), Range("AS7"), Range("AS9"), Range("AU6"), Range("AU7"), Range("AU9"), Range("AZ3"), Range("AZ4")) '28 ranges
        Set InputRange2 = Union(Range("AZ6"), Range("AZ7"), Range("AZ9"), Range("BB6"), Range("BB7"), Range("BB9"), Range("BG3"), Range("BG4"), Range("BG6"), Range("BG7"), Range("BG9"), Range("BI6"), Range("BI7"), Range("BI9"), Range("BN3"), Range("BN4"), Range("BN6"), Range("BN7"), Range("BN9"), Range("BP6"), Range("BP7"), Range("BP9"), Range("BU3"), Range("BU4"), Range("BU6"), Range("BU7"), Range("BU9"), Range("BW6")) '28 ranges
        Set InputRange3 = Union(Range("BW7"), Range("BW9"), Range("CB3"), Range("CB4"), Range("CB6"), Range("CB7"), Range("CB9"), Range("CD6")) '8 ranges
        Set InputRange4 = Union(Range("CD7"), Range("CD9"), Range("C20:D" & cellb.Row - 1), Range("F20:G" & cellb.Row - 1), Range("J20:K" & cellb.Row - 1), Range("M20:N" & cellb.Row - 1), Range("Q20:R" & cellb.Row - 1), Range("T20:U" & cellb.Row - 1), Range("X20:Y" & cellb.Row - 1), Range("AA20:AB" & cellb.Row - 1), Range("AE20:AF" & cellb.Row - 1), Range("AH20:AI" & cellb.Row - 1), Range("AL20:AM" & cellb.Row - 1), Range("AO20:AP" & cellb.Row - 1), Range("AS20:AT" & cellb.Row - 1), Range("AV20:AW" & cellb.Row - 1), Range("AZ20:BA" & cellb.Row - 1), Range("BC20:BD" & cellb.Row - 1), Range("BG20:BH" & cellb.Row - 1), Range("BJ20:BK" & cellb.Row - 1), Range("BN20:BO" & cellb.Row - 1), Range("BQ20:BR" & cellb.Row - 1), Range("BU20:BV" & cellb.Row - 1), Range("BX20:BY" & cellb.Row - 1), Range("CB20:CC" & cellb.Row - 1), Range("CE20:CF" & cellb.Row - 1)) ' 26 ranges with unknown # of cells
        Set InputRange5 = Union(InputRange, InputRange1, InputRange2, InputRange3, InputRange4)
        OldWbk.Activate
        Set InputRange6 = Union(Range("C3"), Range("C4"), Range("C6"), Range("C7"), Range("C9"), Range("E6"), Range("E7"), Range("E9"), Range("J3"), Range("J4"), Range("J6"), Range("J7"), Range("J9"), Range("L6"), Range("L7"), Range("L9"), Range("Q3"), Range("Q4"), Range("Q6"), Range("Q7"), Range("Q9"), Range("S6"), Range("S7"), Range("S9"), Range("X3"), Range("X4"), Range("X6"), Range("X7"), Range("X9"), Range("Z6")) '30 ranges
        Set InputRange7 = Union(Range("Z7"), Range("Z9"), Range("AE3"), Range("AE4"), Range("AE6"), Range("AE7"), Range("AE9"), Range("AG6"), Range("AG7"), Range("AG9"), Range("AL3"), Range("AL4"), Range("AL6"), Range("AL7"), Range("AL9"), Range("AN6"), Range("AN7"), Range("AN9"), Range("AS3"), Range("AS4"), Range("AS6"), Range("AS7"), Range("AS9"), Range("AU6"), Range("AU7"), Range("AU9"), Range("AZ3"), Range("AZ4")) '28 ranges
        Set InputRange8 = Union(Range("AZ6"), Range("AZ7"), Range("AZ9"), Range("BB6"), Range("BB7"), Range("BB9"), Range("BG3"), Range("BG4"), Range("BG6"), Range("BG7"), Range("BG9"), Range("BI6"), Range("BI7"), Range("BI9"), Range("BN3"), Range("BN4"), Range("BN6"), Range("BN7"), Range("BN9"), Range("BP6"), Range("BP7"), Range("BP9"), Range("BU3"), Range("BU4"), Range("BU6"), Range("BU7"), Range("BU9"), Range("BW6")) '28 ranges
        Set InputRange9 = Union(Range("BW7"), Range("BW9"), Range("CB3"), Range("CB4"), Range("CB6"), Range("CB7"), Range("CB9"), Range("CD6")) '8 ranges
        Set InputRange10 = Union(Range("CD7"), Range("CD9"), Range("C20:D" & cellb.Row - 1), Range("F20:G" & cellb.Row - 1), Range("J20:K" & cellb.Row - 1), Range("M20:N" & cellb.Row - 1), Range("Q20:R" & cellb.Row - 1), Range("T20:U" & cellb.Row - 1), Range("X20:Y" & cellb.Row - 1), Range("AA20:AB" & cellb.Row - 1), Range("AE20:AF" & cellb.Row - 1), Range("AH20:AI" & cellb.Row - 1), Range("AL20:AM" & cellb.Row - 1), Range("AO20:AP" & cellb.Row - 1), Range("AS20:AT" & cellb.Row - 1), Range("AV20:AW" & cellb.Row - 1), Range("AZ20:BA" & cellb.Row - 1), Range("BC20:BD" & cellb.Row - 1), Range("BG20:BH" & cellb.Row - 1), Range("BJ20:BK" & cellb.Row - 1), Range("BN20:BO" & cellb.Row - 1), Range("BQ20:BR" & cellb.Row - 1), Range("BU20:BV" & cellb.Row - 1), Range("BX20:BY" & cellb.Row - 1), Range("CB20:CC" & cellb.Row - 1), Range("CE20:CF" & cellb.Row - 1)) ' 26 ranges with unknown # of cells
        Set InputRange11 = Union(InputRange6, InputRange7, InputRange8, InputRange9, InputRange10)
        InputRange11.Select
        Selection.Copy
        NewWbk.Activate
        InputRange5.Select
        Selection.PasteSpecial xlPasteValues
    Else
    End If
ElseIf Answer1 = vbYes Then
    Set LstYr = OldWbk.Worksheets(WshName2).Range("F" & cellb.Row, "G" & cellb.Row, "M" & cellb.Row, "N" & cellb.Row, "T" & cellb.Row, "U" & cellb.Row, "AA" & cellb.Row, "AB" & cellb.Row, "AH" & cellb.Row, "AI" & cellb.Row, "AO" & cellb.Row, "AP" & cellb.Row, "AV" & cellb.Row, "AW" & cellb.Row, "BC" & cellb.Row, "BD" & cellb.Row, "BJ" & cellb.Row, "BK" & cellb.Row, "BQ" & cellb.Row, "BR" & cellb.Row, "BX" & cellb.Row, "BY" & cellb.Row, "CE" & cellb.Row, "CF" & cellb.Row)  '24 ranges
    Set ThisYr = NewWbk.Worksheets(WshName).Range("C3, C4, J3, J4, Q3, Q4, X3, X4, AE3, AE4, AL3, AL4, AS3, AS4, AZ3, AZ4, BG3, BG4, BN3, BN4, BU3, BU4, CB3, CB4") '24 ranges
    OldWbk.Activate
    OldWbk.Worksheets(WshName2).Range("F" & cellb.Row).Select

    For MyCell1 = 1 To 24
        SumArray1(MyCell1) = 0
    Next MyCell1
    MyCell1 = 1

    For Each cell In LstYr
        SumArray1(MyCell1) = cell.Value
        MyCell1 = MyCell1 = 1
    Next cell

    NewWbk.Activate
    MyCell1 = 1
    For Each cell In ThisYr
        cell.Value = SumArray1(MyCell1)
        MyCell1 = MyCell1 = 1
    Next cell
End If
OldWbk.Close SaveChanges:=False
NewWbk.Protect

Application.ScreenUpdating = True

ErrorHandler:
    Resume Next

End Sub

[screenshots hosted on flickr] http://www.flickr.com/photos/32470349@N03/11873809585/

[flickr 上的截图] http://www.flickr.com/photos/32470349@N03/11873809585/

回答by user3179945

The answer L42 provided wouldn't work for my situation, and is definitely a viable solution for situations similar to how he imagined it.

L42 提供的答案不适用于我的情况，对于类似于他想象的情况，这绝对是一个可行的解决方案。

My final working code is shown below. The section below the series of "InputRange" unions that starts with ElseIf Answer1 = vbYes Thenis how I solved the non-contiguous question posted.

我的最终工作代码如下所示。以“InputRange”联合系列开头的部分ElseIf Answer1 = vbYes Then是我如何解决发布的非连续问题的方法。

Option Explicit
Sub UpdateFromOld()

    Dim fd As FileDialog
    Dim NewWbk As Workbook, OldWbk As Workbook
    Dim vrtSelectedItem As Variant, fname As Variant
    Dim cella As Range, cellb As Range, cell1 As Range, cell2 As Range
    Dim cell As Range, PasteRng As Range
    Dim wsh As Worksheet, wsh2 As Worksheet
    Dim WshName As String, WshName2 As String, MyDate As String
    Dim Answer1 As String, Answer2 As String
    Dim UsedRange1 As Range, UsedRange2 As Range
    Dim InputRange As Range, InputRange1 As Range, InputRange2 As Range, InputRange3 As Range, InputRange4 As Range, InputRange5 As Range
    Dim InputRange6 As Range, InputRange7 As Range, InputRange8 As Range, InputRange9 As Range, InputRange10 As Range, InputRange11 As Range
    Dim LstYr1 As Range, LstYr2 As Range, ThisYr1 As Range, ThisYr2 As Range
    Dim ExtraRows As Integer, RowCounter As Integer
    Dim SumArray1(12)
    Dim MyCell1

    On Error GoTo ErrorHandler

    Range("B5").Select
    WshName = InputBox("Type in your location name", "Annual Ad Planner")
    MyDate = InputBox("Enter the year you are working on in YYYY format.", "Annual Ad Planner")
    Set NewWbk = ThisWorkbook
    NewWbk.Unprotect
    ActiveSheet.Unprotect
    Range("A6").Value = "1/10/" & MyDate
    Range("B5").Value = WshName
    ActiveSheet.Name = WshName
    Set wsh = NewWbk.Worksheets(WshName)

    'Application.ScreenUpdating = False

    'select the old file to update from
    MsgBox "In the next window, navigate to and select the Ad Planner file you are updating from.", vbOKOnly, "Annual Ad Planner"
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Add "Previous Ad Planner", "*.xls", 1
        If .Show = -1 Then
            For Each vrtSelectedItem In .SelectedItems
                fname = vrtSelectedItem
            Next vrtSelectedItem
        Else
            MsgBox "You ended the update process.", vbOKOnly, "Annual Ad Planner"
            GoTo ErrorHandler
        End If
    End With

    Set OldWbk = Workbooks.Open(fname)
    OldWbk.Unprotect
    Set fd = Nothing


    NewWbk.Worksheets(WshName).Visible = True
    NewWbk.Worksheets(WshName).Activate
    NewWbk.Worksheets(WshName).Unprotect
    Set cella = Cells(Rows.Count, "A").End(xlUp).Offset(0, 0)
    Range("A" & cella.Row).Select

    OldWbk.Activate
    Range("B5").Select
    WshName2 = ActiveCell.Worksheet.Name
    Set wsh2 = Worksheets(WshName2)
    OldWbk.Worksheets(WshName2).Visible = True
    OldWbk.Worksheets(WshName2).Activate
    OldWbk.Worksheets(WshName2).Unprotect
    Set cellb = Cells(Rows.Count, "A").End(xlUp).Offset(0, 0)
    Range("A" & cellb.Row).Select

    Range("B5").Select
    Selection.Copy
    NewWbk.Activate
    Range("B5").Select
    Range("B5").PasteSpecial xlPasteValues

    Range("B23").Select
    If cellb.Row > cella Then
        ExtraRows = cellb.Row - cella
        For RowCounter = 1 To ExtraRows
            AddRow
        Next RowCounter
    End If
    NewWbk.Unprotect
    NewWbk.Worksheets(WshName).Unprotect

    'Copy & Paste list of lead sources
    OldWbk.Activate
    Range("B20:B" & cellb.Row - 1).Select
    Selection.Copy
    NewWbk.Activate
    Range("B20").Select
    Range("B20").PasteSpecial xlPasteValues

    'Copy & Paste classifications & segments
    OldWbk.Activate
    Range("CI20:CK" & cellb.Row - 1).Select
    Selection.Copy
    NewWbk.Activate
    Range("CI20").Select
    Range("CI20").PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    Answer1 = MsgBox("Are you importing sources and totals from last year's file?", vbYesNoCancel, "Annual Ad Planner")
    If Answer1 = vbNo Then
        Answer2 = MsgBox("Are you updating the current file to the new format?", vbYesNoCancel, "Annual Ad Planner")
        If Answer2 = vbYes Then
            Set InputRange = Union(Range("C3"), Range("C4"), Range("C6"), Range("C7"), Range("C9"), Range("E6"), Range("E7"), Range("E9"), Range("J3"), Range("J4"), Range("J6"), Range("J7"), Range("J9"), Range("L6"), Range("L7"), Range("L9"), Range("Q3"), Range("Q4"), Range("Q6"), Range("Q7"), Range("Q9"), Range("S6"), Range("S7"), Range("S9"), Range("X3"), Range("X4"), Range("X6"), Range("X7"), Range("X9"), Range("Z6")) '30 ranges
            Set InputRange1 = Union(Range("Z7"), Range("Z9"), Range("AE3"), Range("AE4"), Range("AE6"), Range("AE7"), Range("AE9"), Range("AG6"), Range("AG7"), Range("AG9"), Range("AL3"), Range("AL4"), Range("AL6"), Range("AL7"), Range("AL9"), Range("AN6"), Range("AN7"), Range("AN9"), Range("AS3"), Range("AS4"), Range("AS6"), Range("AS7"), Range("AS9"), Range("AU6"), Range("AU7"), Range("AU9"), Range("AZ3"), Range("AZ4")) '28 ranges
            Set InputRange2 = Union(Range("AZ6"), Range("AZ7"), Range("AZ9"), Range("BB6"), Range("BB7"), Range("BB9"), Range("BG3"), Range("BG4"), Range("BG6"), Range("BG7"), Range("BG9"), Range("BI6"), Range("BI7"), Range("BI9"), Range("BN3"), Range("BN4"), Range("BN6"), Range("BN7"), Range("BN9"), Range("BP6"), Range("BP7"), Range("BP9"), Range("BU3"), Range("BU4"), Range("BU6"), Range("BU7"), Range("BU9"), Range("BW6")) '28 ranges
            Set InputRange3 = Union(Range("BW7"), Range("BW9"), Range("CB3"), Range("CB4"), Range("CB6"), Range("CB7"), Range("CB9"), Range("CD6")) '8 ranges
            Set InputRange4 = Union(Range("CD7"), Range("CD9"), Range("C20:D" & cellb.Row - 1), Range("F20:G" & cellb.Row - 1), Range("J20:K" & cellb.Row - 1), Range("M20:N" & cellb.Row - 1), Range("Q20:R" & cellb.Row - 1), Range("T20:U" & cellb.Row - 1), Range("X20:Y" & cellb.Row - 1), Range("AA20:AB" & cellb.Row - 1), Range("AE20:AF" & cellb.Row - 1), Range("AH20:AI" & cellb.Row - 1), Range("AL20:AM" & cellb.Row - 1), Range("AO20:AP" & cellb.Row - 1), Range("AS20:AT" & cellb.Row - 1), Range("AV20:AW" & cellb.Row - 1), Range("AZ20:BA" & cellb.Row - 1), Range("BC20:BD" & cellb.Row - 1), Range("BG20:BH" & cellb.Row - 1), Range("BJ20:BK" & cellb.Row - 1), Range("BN20:BO" & cellb.Row - 1), Range("BQ20:BR" & cellb.Row - 1), Range("BU20:BV" & cellb.Row - 1), Range("BX20:BY" & cellb.Row - 1), Range("CB20:CC" & cellb.Row - 1), Range("CE20:CF" & cellb.Row - 1)) ' 26 ranges with unknown # of cells
            Set InputRange5 = Union(InputRange, InputRange1, InputRange2, InputRange3, InputRange4)
            OldWbk.Activate
            Set InputRange6 = Union(Range("C3"), Range("C4"), Range("C6"), Range("C7"), Range("C9"), Range("E6"), Range("E7"), Range("E9"), Range("J3"), Range("J4"), Range("J6"), Range("J7"), Range("J9"), Range("L6"), Range("L7"), Range("L9"), Range("Q3"), Range("Q4"), Range("Q6"), Range("Q7"), Range("Q9"), Range("S6"), Range("S7"), Range("S9"), Range("X3"), Range("X4"), Range("X6"), Range("X7"), Range("X9"), Range("Z6")) '30 ranges
            Set InputRange7 = Union(Range("Z7"), Range("Z9"), Range("AE3"), Range("AE4"), Range("AE6"), Range("AE7"), Range("AE9"), Range("AG6"), Range("AG7"), Range("AG9"), Range("AL3"), Range("AL4"), Range("AL6"), Range("AL7"), Range("AL9"), Range("AN6"), Range("AN7"), Range("AN9"), Range("AS3"), Range("AS4"), Range("AS6"), Range("AS7"), Range("AS9"), Range("AU6"), Range("AU7"), Range("AU9"), Range("AZ3"), Range("AZ4")) '28 ranges
            Set InputRange8 = Union(Range("AZ6"), Range("AZ7"), Range("AZ9"), Range("BB6"), Range("BB7"), Range("BB9"), Range("BG3"), Range("BG4"), Range("BG6"), Range("BG7"), Range("BG9"), Range("BI6"), Range("BI7"), Range("BI9"), Range("BN3"), Range("BN4"), Range("BN6"), Range("BN7"), Range("BN9"), Range("BP6"), Range("BP7"), Range("BP9"), Range("BU3"), Range("BU4"), Range("BU6"), Range("BU7"), Range("BU9"), Range("BW6")) '28 ranges
            Set InputRange9 = Union(Range("BW7"), Range("BW9"), Range("CB3"), Range("CB4"), Range("CB6"), Range("CB7"), Range("CB9"), Range("CD6")) '8 ranges
            Set InputRange10 = Union(Range("CD7"), Range("CD9"), Range("C20:D" & cellb.Row - 1), Range("F20:G" & cellb.Row - 1), Range("J20:K" & cellb.Row - 1), Range("M20:N" & cellb.Row - 1), Range("Q20:R" & cellb.Row - 1), Range("T20:U" & cellb.Row - 1), Range("X20:Y" & cellb.Row - 1), Range("AA20:AB" & cellb.Row - 1), Range("AE20:AF" & cellb.Row - 1), Range("AH20:AI" & cellb.Row - 1), Range("AL20:AM" & cellb.Row - 1), Range("AO20:AP" & cellb.Row - 1), Range("AS20:AT" & cellb.Row - 1), Range("AV20:AW" & cellb.Row - 1), Range("AZ20:BA" & cellb.Row - 1), Range("BC20:BD" & cellb.Row - 1), Range("BG20:BH" & cellb.Row - 1), Range("BJ20:BK" & cellb.Row - 1), Range("BN20:BO" & cellb.Row - 1), Range("BQ20:BR" & cellb.Row - 1), Range("BU20:BV" & cellb.Row - 1), Range("BX20:BY" & cellb.Row - 1), Range("CB20:CC" & cellb.Row - 1), Range("CE20:CF" & cellb.Row - 1)) ' 26 ranges with unknown # of cells
            Set InputRange11 = Union(InputRange6, InputRange7, InputRange8, InputRange9, InputRange10)
            InputRange11.Select
            For Each cell In InputRange11
                OldWbk.Activate
                InputRange5.Range(cell.Address).Offset(-2, -2).Value = InputRange11.Range(cell.Address).Offset(-2, -2).Value
            Next
            NewWbk.Activate
            Range("B5").Value = WshName
        Else
        End If
    ElseIf Answer1 = vbYes Then
        OldWbk.Activate
        Set LstYr1 = Union(Range("F" & cellb.Row - 10), Range("M" & cellb.Row - 10), Range("T" & cellb.Row - 10), Range("AA" & cellb.Row - 10), Range("AH" & cellb.Row - 10), Range("AO" & cellb.Row - 10), Range("AV" & cellb.Row - 10), Range("BC" & cellb.Row - 10), Range("BJ" & cellb.Row - 10), Range("BQ" & cellb.Row - 10), Range("BX" & cellb.Row - 10), Range("CE" & cellb.Row - 10))  '12 ranges
        Set LstYr2 = Union(Range("G" & cellb.Row - 10), Range("N" & cellb.Row - 10), Range("U" & cellb.Row - 10), Range("AB" & cellb.Row - 10), Range("AI" & cellb.Row - 10), Range("AP" & cellb.Row - 10), Range("AW" & cellb.Row - 10), Range("BD" & cellb.Row - 10), Range("BK" & cellb.Row - 10), Range("BR" & cellb.Row - 10), Range("BY" & cellb.Row - 10), Range("CF" & cellb.Row - 10))  '12 ranges
        NewWbk.Activate
        Set ThisYr1 = Union(Range("C3"), Range("J3"), Range("Q3"), Range("X3"), Range("AE3"), Range("AL3"), Range("AS3"), Range("AZ3"), Range("BG3"), Range("BN3"), Range("BU3"), Range("CB3")) '24 ranges
        Set ThisYr2 = Union(Range("C4"), Range("J4"), Range("Q4"), Range("X4"), Range("AE4"), Range("AL4"), Range("AS4"), Range("AZ4"), Range("BG4"), Range("BN4"), Range("BU4"), Range("CB4")) '24 ranges

        For MyCell1 = 1 To 12
            SumArray1(MyCell1) = 0
        Next MyCell1
        MyCell1 = 1

        OldWbk.Activate
        For Each cell In LstYr1
            Range(cell.Address).Select
            SumArray1(MyCell1) = cell.Value
            MyCell1 = MyCell1 + 1
        Next cell

        MyCell1 = 1
        NewWbk.Activate
        For Each cell2 In ThisYr2
            Range(cell2.Address).Select
            cell2.Value = SumArray1(MyCell1)
            MyCell1 = MyCell1 + 1
        Next cell2

        For MyCell1 = 1 To 12
            SumArray1(MyCell1) = 0
        Next MyCell1
        MyCell1 = 1

        OldWbk.Activate
        For Each cell In LstYr2
            Range(cell.Address).Select
            SumArray1(MyCell1) = cell.Value
            MyCell1 = MyCell1 + 1
        Next cell

        MyCell1 = 1
        NewWbk.Activate
        For Each cell2 In ThisYr1
            Range(cell2.Address).Select
            cell2.Value = SumArray1(MyCell1)
            MyCell1 = MyCell1 + 1
        Next cell2

        NewWbk.Activate
        Range("B5").Value = WshName

    End If
    OldWbk.Close SaveChanges:=False
    NewWbk.Protect
    ActiveSheet.Protect
    Range("C3").Select

    Application.ScreenUpdating = True

ErrorHandler:
        Resume Next

End Sub

回答by L42

Upon checking your code, i found out that you really are copying and pasting the entire selection from the Old Wbto the New Wbat exactly the same address right?
I'm not going to answer your question directly but if above statement is true, you can use this approach:

检查您的代码后，我发现您确实是在完全相同的地址复制和粘贴从Old Wb到 的整个选择，New Wb对吗？
我不会直接回答您的问题，但如果上述陈述属实，您可以使用以下方法：

Suppose you have data like this as your source:

假设你有这样的数据作为你的来源：

And you want to paste data in another workbook with this data:

并且您想使用此数据将数据粘贴到另一个工作簿中：

Then you can use this approach:

然后你可以使用这种方法：

Sub test()

Dim copyRng As Range, cel As Range, _
    pasteRng As Range

Set copyRng = ThisWorkbook.Sheets("Sheet1").Range("B2,B4,C3,D5:E5")
Set pasteRng = ThisWorkbook.Sheets("Sheet2").Range("A1")

For Each cel In copyRng
    cel.Copy
    pasteRng.Range(cel.Address).PasteSpecial xlPasteValues
Next
Application.CutCopyMode = False
End Sub

The result will be like this:

结果将是这样的：

Hope this gets you started on what you want to accomplish.
And I don't think you need to use Unionat all.

希望这能让你开始你想要完成的事情。
而且我认为您根本不需要使用Union。