Copy multiple ranges

[bujaman]

I am attempting to copy multiple ranges of cells from one worksheet and paste them into another to the next open row. What the code does is look through a selected workbook for worksheets that begin with certain characters (see the "CASE" below), and then copies the specified ranges to the next open row. I am having some problems with the

sh.Range("A8:BH48,A55:BH104,A113:BH130,A133:BH152,A158:BH160,A164:BH166,A172:BH174").Select

part of the code. Any help would be awesome! Thanks!

Private Sub InstallProducts_Click()


Application.ScreenUpdating = False
If FilePath.Value = "" Then
MsgBox "Please Select a File to Install", vbOKOnly, "Blind Bid Pro"
Exit Sub

Else
Unload Me

Dim wkbSource As Workbook
Dim WorkbookName As String
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim LastRow As Long
Dim wbsnum As Range

Set DestSh = Worksheets("Cost Summary")


WorkbookName = ThisWorkbook.Name

    Set wkbSource = Workbooks.Open(FilePath.Value)


DestSh.Activate
For Each sh In wkbSource.Worksheets



    Select Case Left(sh.Name, 4)

        Case "C.01" ', "D.01", "D.02", "D.03", "E.01", "E.02", "E.03", "E.04", "E.05", "E.06", "E.07", "F.01", "F.04", "F.05", "F.06", "G.01", "G.02", "H.01", "H.02", "I.01", "Z.01", "Z.02", "Z.03", "Z.04", "F.02", "F.03", "Y.01", "Y.02"
    '...add all WBS numbers here, there will be many!
            LastRow = FindLastRow(DestSh, "B")

            sh.Range("A8:BH48,A55:BH104,A113:BH130,A133:BH152,A158:BH160,A164:BH166,A172:BH174").Select
            Selection.Copy
            DestSh.Cells(LastRow + 2, 2).Select

            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            ActiveCell.Offset(0, -1) = Left(sh.Range("A3").Text, 18) 'Left(sh.Name, 4)
            ActiveCell.Offset(0, -1).Copy
            Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(41, -1)).Select
            ActiveSheet.Paste


    End Select

Next sh


wkbSource.Activate

ActiveWorkbook.Close SaveChanges:=False


ActiveWorkbook.Save
Range("A1").Select

End If
    Range("A4:C65536").Select
    Selection.AutoFilter
    Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[Boller]

You need to loop through each area in the range to be copied.

For example :-

Dim area as Range
For Each area in Selection.Areas
    area.Copy
    'your paste code,etc.
Next