Question

我有一个早先的问题得到了很好的回答，我得到了以下代码，这些代码在一个测试环境中完美运行，其中代码循环3张，只有1张数据和3列。

以下是我修改后的代码，要经过16列。但是我认为我面临的问题是，在实时环境中打开工作表时，子工作簿都包含4个选项卡，分别是“查找”，“详细信息”，“摘要”和“呼叫”。

代码包含For Each sheet In ActiveWorkbook.Worksheets

我只想从“调用”选项卡中的循环中的每个工作簿中获取以下代码中的数据。任何人都可以建议对现有循环进行任何更改吗？

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

Answer 1

不要使用循环，只需将For 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

Answer 2

你可能会追随以下内容：

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

在循环数据时无法从设置表复制

2 个答案: