データをループする際にセットシートからコピーできません

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

を使用してコピーを短縮することができます

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 

Answer 2

代わりにループを使用しての、ちょうど

Set sheet = wbk.Worksheets("Calls") 

とFor Each sheet ...ラインを交換（および削除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