复制范围并忽略所有工作表中的空白到“汇总”工作表
我迫切需要帮助，几天来一直困扰着我的大脑。
本质上，我正在尝试创build代码（我对VBA非常新），它将遍历所有工作表并将这些单元格和/或范围复制到Summary表中。 我只需要它在数据存在的情况下复制，所以我忽略任何空白。
我想要复制的单元格/范围是：
B5 H10:H34 H38:H49 R37 Q10:Q20
基本上数据将显示为：
客户名称： B5
A组产品： H10:H34 （忽略空白）
B组产品： H38:H49 （忽略空白细胞）
在线服务要求： R37
select的外部服务： 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
然后我希望数据显示在整个列的汇总表中，以便列A中的表1数据列B中的表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
我插入，如果它应该是，如果你还想检查0值，你只需要写OR <> 0 。
无论如何，你现在的代码在每一张表中检查相同的范围。 这利用了许多不必要的循环。 我会build议为每个表单build立一个单独的循环，如下所示：
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
这似乎是不必要的代码，但它给予你更多的可能性，避免不必要的长循环。 你可以做比起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
就我所能理解的，至less在我的testing中，这个代码以一种简单的方式来做你想要的。 希望这是有帮助的。
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