在循环数据时无法从设置表中复制
我有一个早先的问题，这是慷慨的回答，我被给了下面的代码，完美的工作在一个testing环境中代码循环了3张，只有1张数据和3列完美。
以下是我推荐的代码，通过16列。 然而，我相信我正面临的问题是，在实时环境中打开工作表时，子工作簿都包含“查找”，“详细信息”，“摘要”和“呼叫”4个选项卡。
该代码包含For Each sheet In ActiveWorkbook.Worksheets
我只想从“Calls”选项卡的循环中的每个工作簿中获取下面的代码中的数据。 任何人都可以推荐任何改变现有的循环来做到这一点？
Sub Theloopofloops() Dim wbk As Workbook Dim Filename As String Dim path As String Dim rCell As Range Dim rRng As Range Dim wsO As Worksheet Dim sheet As Worksheet Set sheet = ActiveWorkbook.Sheets(Sheet2) path = "M:\Documents\Call Logger\" Filename = Dir(path & "*.xlsm") Set wsO = ThisWorkbook.Sheets("Master") Do While Len(Filename) > 0 DoEvents Set wbk = Workbooks.Open(path & Filename, True, True) For Each sheet In ActiveWorkbook.Worksheets Set rRng = sheet.Range("A2:A20000") For Each rCell In rRng.Cells If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rCell wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = rCell.Offset(0, 1) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 2).Value = rCell.Offset(0, 2) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 3).Value = rCell.Offset(0, 3) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 4).Value = rCell.Offset(0, 4) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 5).Value = rCell.Offset(0, 5) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 6).Value = rCell.Offset(0, 6) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 7).Value = rCell.Offset(0, 7) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 8).Value = rCell.Offset(0, 8) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 9).Value = rCell.Offset(0, 9) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 10).Value = rCell.Offset(0, 10) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 11).Value = rCell.Offset(0, 11) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 12).Value = rCell.Offset(0, 12) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 13).Value = rCell.Offset(0, 13) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 14).Value = rCell.Offset(0, 14) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 15).Value = rCell.Offset(0, 15) End If Next rCell Next sheet wbk.Close False Filename = Dir Loop End Sub
你可能会在以下之后：
Option Explicit Sub Theloopofloops() Dim wbk As Workbook Dim Filename As String Dim path As String Dim rCell As Range Dim wsO As Worksheet path = "M:\Documents\Call Logger\" Filename = Dir(path & "*.xlsm") Set wsO = ThisWorkbook.Sheets("Master") Do While Len(Filename) > 0 DoEvents Set wbk = Workbooks.Open(path & Filename, True, True) For Each rCell In ActiveWorkbook.Worksheets("Calls").Range("A2:A20000") If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(, 16).Value = rCell.Resize(, 16).Value End If Next rCell wbk.Close False Filename = Dir Loop End Sub
而不是使用循环，只需将For Each sheet ...行replaceFor Each sheet ...
Set sheet = wbk.Worksheets("Calls")
（并删除Next sheet ）
你甚至可以缩短和使用
Set rRng = wbk.Worksheets("Calls").Range("A2:A20000")
甚至跳过并使用
For Each rCell In wbk.Worksheets("Calls").Range("A2:A20000").Cells
您也可以使用缩短复制
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 16).Value = rCell.Resize(1, 16).Value