Hello
I modified John Walkenbach’s CopyMultipleSelection to copy multiple
areas from each worksheet in workbook AA to worksheet in workbook BB.
All the sheets in BB will have the same name as those in AA. Example:
Copy selected areas in worksheet “LA” in workbook AA to similarly
named worksheet “LA” in workbook BB.


Here are the modified codes. It errors out on the line
SelAreas(i).Copy pasteRange.Offset(RowOffset, ColOffset).
I would appreciate someone pointing me in the right direction.


Sub CopyMultipleSelection()
'This code is in a module in workbook BB

Dim qq As Integer: Dim tt As Integer
Dim BB As Workbook: Set BB = ThisWorkbook
Dim rAcells As Range:
Dim SelAreas() As Range: Dim PasteRange As Range:
Dim UpperLeft As Range: Dim NumAreas As Integer, i As Integer
Dim TopRow As Long, LeftCol As Integer: Dim RowOffset As Long,
ColOffset As Integer

Application.Calculation = xlCalculationManual

qq = 0
For tt = 1 To Workbooks.Count
If Windows(Workbooks(tt).Name).Visible = True Then
qq = qq + 1
If BB.Name < Workbooks(tt).Name Then
Windows(Workbooks(tt).Name).Activate
Range("F11").Value = BB.Name ' In workbook AA, set name of
workbook BB
End If
End If
Next tt
If qq = 1 Then GoTo WarningMessage
If qq 2 Then GoTo WarningMessage2

If BB.Name < Range("F11").Value Then
Windows(Range("F11").Value).Activate 'activate workbook AA
Set rAcells = ActiveSheet.Range("E15:CI86")
Dim rNumTextcells As Range:
On Error Resume Next: Set rNumTextcells =
rAcells.SpecialCells(xlCellTypeConstants) 'select areas in AA to
copy to workbook BB

ActiveSheet.Range("F10") = ActiveSheet.Name 'name of worksheet in AA

rNumTextcells.Select: 'areas selected to copy to worksheet in BB

' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
Set SelAreas(i) = Selection.Areas(i)
Next

' Determine the upper left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count

For i = 1 To NumAreas
If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
If SelAreas(i).Column < LeftCol Then LeftCol =
SelAreas(i).Column
Next
Set UpperLeft = Cells(TopRow, LeftCol)

On Error Resume Next

On Error GoTo 0

' Make sure only the upper left cell is used
Set PasteRange = UpperLeft.Range("A1")
Set PasteRange =
Workbooks(Range("F11").Value).Worksheets(Range("F1 0").Value).Range(PasteRange.Address)
'determine the upper left cell in workbook BB

For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
Next i

Range("F11").ClearContents: Range("F10").ClearContents
Application.Calculation = xlCalculationAutomatic
Exit Sub

WarningMessage:
MsgBox ("Only 1 worksbook in windows - you need 2 workbooks to run
this macro")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

WarningMessage2:
MsgBox ("Only 2 worksbooks are allowed - the original workbook and
the new workbook")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub