Copying Range and ignoring blanks from all worksheets to 'Summary' Sheet

Question

I am in desperate need of help and have been racking my brain for a few days now.

Essentially, I am trying to create code (I am very new to VBA) that will go through all worksheets and copy these cells and/or ranges to a Summary Sheet. I need it to copy only when data exists, so I ignore any blanks.

The cells/ranges I want to copy across are:

B5
H10:H34 
H38:H49 
R37 
Q10:Q20

Essentially the data would be displayed as:

Client Name: B5

Products from Group A: H10:H34 (ignoring blank cells)

Products from Group B: H38:H49 (ignoring blank cells)

Online Service Requested: R37

External Services Selected: Q10:Q20 (ignoring blank cells)

I have written code that will cycle through each worksheet but cannot seem to get it to work for the ranges and ignoring blank cells.

Could someone please help me? This is my code so far:

Sub Summary_All_Worksheets_With_Formulas()
    Dim Sh As Worksheet
    Dim Req As Worksheet
    Dim myCell As Range
    Dim ColNum As Integer
    Dim RwNum As Long
    Dim basebook As Workbook
        With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Add a worksheet with the name "Requirements Gathering"
    Set basebook = ThisWorkbook
    Set Req = Worksheets("Requirements Gathering")
    'The links to the first sheet will start column 2
    ColNum = 1

    For Each Sh In basebook.Worksheets
        If Sh.Name <> Req.Name And Sh.Visible Then
            RwNum = 16
            ColNum = ColNum + 1
            Columns("C:C").Insert , CopyOrigin:=xlFormatFromLeftOrAbove

            'Copy the sheet name in the A column
            Req.Cells(RwNum, ColNum).Value = Sh.Name
                For Each myCell In Sh.Range("B5,R37")
                RwNum = RwNum + 1
                Req.Cells(RwNum, ColNum).Formula = _
                "='" & Sh.Name & "'!" & myCell.Address(False, False)
                Req.Cells.NumberFormat = "General"

                Next myCell
        End If

    Next Sh

    Req.UsedRange.Columns.AutoFit
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Then I want the data to display in the Summary sheet across the columns so sheet 1 data in column A sheet 2 in column B etc.

I know I am probably asking a hell of a lot but I just can't work this one out.

Super appreciation in advance for anyone who could help me.

Answer 1

Sub Summary_All_Worksheets_With_Formulas()
    Dim Sh As Worksheet
    Dim Req As Worksheet
    Dim myCell As Range
    Dim ColNum As Integer
    Dim RwNum As Long
    Dim basebook As Workbook
        With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Add a worksheet with the name "Requirements Gathering"
    Set basebook = ThisWorkbook
    Set Req = Worksheets("Requirements Gathering")
    'The links to the first sheet will start column 2
    ColNum = 1

    For Each Sh In basebook.Worksheets
        If Sh.Name <> Req.Name And Sh.Visible Then
            RwNum = 16
            ColNum = ColNum + 1
            Columns("C:C").Insert , CopyOrigin:=xlFormatFromLeftOrAbove

            'Copy the sheet name in the A column

            Req.Cells(RwNum, ColNum).Value = Sh.Name
                For Each myCell In Sh.Range("B5,R37")
                  If myCell.Value <> "" Then

                    RwNum = RwNum + 1
                    Req.Cells(RwNum, ColNum).Formula = _"='" & Sh.Name & "'!" & myCell.Address(False, False)
                    Req.Cells.NumberFormat = "General"

                    myCell.Copy 
                    'This stores an reference of the cell just like strg + c

                    Req.Cells(RwNum, ColNum).PasteSpecial Paste:=xlPasteFormats 
                    'This pastes the stored value, with the paste attribute xlPasteFormats it only paste the format not the value it self
                  End If
                Next myCell
        End If

    Next Sh

    Req.UsedRange.Columns.AutoFit
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

I inserted the if like it should be, if you also want to check for 0 values you just have to write OR <> 0.

Anyway your code at the moment checks in every sheet for the same Range. This leeds to many unecessary loops. I would recomment to build a seperate loop for each sheet like:

If Sh.Name = "Products from Group A" Then
  Req.Cells(RwNum, ColNum).Value = Sh.Name
  For Each myCell In Sh.Range("H38,H49")
    'Your Custom loop for Sheet
  Next myCell
End If

This seems like much unecessary code but it grants you much more possibilitys and avoid unecessary long loops. You could than do stuff like color the products from group a different than the ones from group b.

To separate it in rows it should look like this:

Sub Summary_All_Worksheets_With_Formulas()
        Dim Sh As Worksheet
        Dim Req As Worksheet
        Dim myCell As Range
        Dim ColNum As Integer
        Dim RwNum As Long
        Dim basebook As Workbook
            With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
        End With

        'Add a worksheet with the name "Requirements Gathering"
        Set basebook = ThisWorkbook
        Set Req = Worksheets("Requirements Gathering")
        'The links to the first sheet will start column 2
        RwNum = 15 'We declare it in front of the loop to keep it. set here the first line your summary should start (Line it should start -1)

        For Each Sh In basebook.Worksheets
            If Sh.Name <> Req.Name And Sh.Visible Then
                ColNum = 2 'We reset it for each sheet to col2
                Columns("C:C").Insert , CopyOrigin:=xlFormatFromLeftOrAbove
                RwNum = RwNum + 1 ' Every new Data Sheet we increase the row by 1 
                'Copy the sheet name in the A column

                Req.Cells(RwNum, ColNum).Value = Sh.Name
                    For Each myCell In Sh.Range("B5,R37")
                      If myCell.Value <> "" Then

                        ColNum = ColNum + 1 'Here we now just increase the col for each entry it should fill 
                        Req.Cells(RwNum, ColNum).Formula = _"='" & Sh.Name & "'!" & myCell.Address(False, False)
                        Req.Cells.NumberFormat = "General"

                        myCell.Copy 
                        'This stores an reference of the cell just like strg + c

                        Req.Cells(RwNum, ColNum).PasteSpecial Paste:=xlPasteFormats 
                        'This pastes the stored value, with the paste attribute xlPasteFormats it only paste the format not the value it self
                      End If
                    Next myCell
            End If

        Next Sh

        Req.UsedRange.Columns.AutoFit
        With Application
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
    End Sub

Eventually based on the amount of data you have to set ColNum as Long like you did with RwNum