复制范围并忽略所有工作表中的空白到 'Summary' Sheet

Question

急需帮助，这几天绞尽脑汁

本质上，我正在尝试创建代码（我对 VBA 很陌生），它将完成所有工作 sheet 并将这些单元格 and/or 范围复制到 Summary Sheet。我需要它只在数据存在时复制，所以我忽略任何空白。

我要复制的cells/ranges是：

B5
H10:H34 
H38:H49 
R37 
Q10:Q20

基本上数据将显示为：

客户名称：B5

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

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

请求在线服务：R37

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

我已经编写了循环执行每项工作的代码sheet，但似乎无法让它在范围内工作并忽略空白单元格。

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

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

然后我希望数据显示在摘要 sheet 中跨列，因此 sheet A 列中的 1 个数据 sheet B 列中的 2 个数据等

我知道我可能问了很多问题，但我就是无法解决这个问题。

非常感谢任何能帮助我的人。

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

我按原样插入了 if，如果您还想检查 0 值，只需编写 OR <> 0.

无论如何，您的代码此时会在每个 sheet 中检查相同的范围。这会导致许多不必要的循环。我建议为每个 sheet 构建一个单独的循环，例如：

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

所做的那样

Answer 2

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

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

复制范围并忽略所有工作表中的空白到 'Summary' Sheet

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

excel

vba

summary