复制范围并忽略所有工作表中的空白到“摘要”＆＃39;片

Question

我迫切需要帮助，现在已经绞尽脑汁待了几天。

基本上，我正在尝试创建代码（我是VBA的新手），它将遍历所有工作表并将这些单元格和/或范围复制到Summary工作表。我需要它只在数据存在时才复制，所以我忽略了任何空白。

我要复制的单元格/范围是：

B5
H10:H34 
H38:H49 
R37 
Q10:Q20

基本上，数据显示为：

客户名称：B5

A组产品：H10:H34（忽略空白单元格）

B组产品：H38:H49（忽略空白单元格）

要求在线服务：R37

选择外部服务：Q10:Q20（忽略空白单元格）

我编写的代码将遍历每个工作表，但似乎无法使其适用于范围并忽略空白单元格。

有人可以帮帮我吗？到目前为止，这是我的代码：

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

然后我希望数据显示在列中的摘要表中，因此第1列中的表1数据列B中的表2等。

我知道我可能会问很多但是我不能解决这个问题。

对任何可以帮助我的人提前超级欣赏。

Answer 1

据我所知，这段代码以简单的方式完成了你想要的，至少在我的测试中。希望它有所帮助。

Option Explicit
Sub copyToSummarySheet()
Dim sumSh As Worksheet, sh As Worksheet, i As Integer
Dim cell As Range, sumR As Range, sumCol As Integer
Dim r(1 To 5) As String
Set sumSh = Worksheets("sum")
r(1) = "B5"
r(2) = "H10:H34"
r(3) = "H38:H49"
r(4) = "R37"
r(5) = "Q10:Q20"
sumCol = 0
For Each sh In Worksheets
  Set sumR = sumSh.Range("A16")
  Set sumR = sumR.Offset(0, sumCol)
  If sh.Name <> sumSh.Name Then
    For i = 1 To 5
      For Each cell In sh.Range(r(i))
        If cell <> "" Then
          sumR = cell
          Set sumR = sumR.Offset(1, 0)
        End If
      Next cell
    Next i
    sumCol = sumCol + 1
  End If
Next sh
End Sub

Answer 2

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

我插入if应该是，如果你还要检查0值，你只需要写OR <> 0。

无论如何，您的代码目前会在每个工作表中检查相同的范围。这导致许多不必要的循环。我建议为每张表格建立一个单独的循环，如：

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

这似乎是非常不必要的代码，但它给你更多的可能性并避免不必要的长循环。你可以做一些事情，比如给组a中的产品着色不同于b组的产品。

要将它分隔成行，它应如下所示：

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

最终根据您必须将ColNum设置为Long的数据量与RwNum

相同