複数のワークシートでのデータの抽出

Question

私はVBAにはまったく新しく、エクセルモジュールをスクリプト化して、ワークブックの各シートに特定のセクションを抽出し、それらをフォーマットして新しいブックに1枚ずつ出力することを試みています。

これまで私はこれを持っています。

Public Sub extractCol() 

    ' Find FF&E Section, Add 3 rows and Identify relevant columns. 

    Dim rFind As Range 

    With Range("A:A") 
     Set rFind = .Find(What:="FF&E", LookAt:=xlWhole, MatchCase:=False, 
     SearchFormat:=False) 
     If Not rFind Is Nothing Then 

      NumRange = rFind.Row + 3 ' Find FF&E line and add three 
      CRange = "C" & NumRange & ":" & "C" & NumRange + 100 ' Define First 100 
      Lines in Column C 
      ERange = "E" & NumRange & ":" & "E" & NumRange + 100 ' Define First 100 
      Lines in Column E 
      KRange = "K" & NumRange & ":" & "K" & NumRange + 100 ' Define First 100 
      Lines in Column K 
      MRange = "M" & NumRange & ":" & "M" & NumRange + 100 ' Define First 100 
      Lines in Column M 


      Set range1 = Union(Range(CRange), Range(ERange), Range(KRange), 
      Range(MRange)) ' Combine individual column ranges in to one selection 
      range1.Copy ' Copy new combined range 

      Set NewBook = Workbooks.Add ' Open new Workbook 
      ActiveCell.PasteSpecial Paste:=xlPasteValues ' Paste to new Workbook 

     End If 

    End With 

End Sub 

これは私が正しくしていないビットを抽出するので素晴らしいですが、それは現在のシートだけです。すべてのシートを処理するにはどのようにループするのですか？

2番目に、すべての結果を同じシートに貼り付けたいと思いますか？

最後に、シート名を抽出してフォーマットする以下のスクリプトがあります。理想的には、出力先のシートに応じてこのデータを表示する列を出力に追加したいと考えています。

Function FindRoom() 

    shtName = ActiveSheet.Name 

    Dim arr() As String 
    arr = VBA.Split(shtName, " ") 

    xCount = UBound(arr) 
    If xCount < 1 Then 
     FindRoom = "" 
    Else 
     FindRoom = arr(xCount) 
    End If 
End Function 

申し訳ありませんが、私は、これは、単純な答えは一つの問題ではないですが、それだけで正しい方向に私を指していても、すべてのヘルプは感謝される知っています。

Answer 1

これを試してください。ワークシート変数wsを追加しました。これにより、新しいブックの列Aにシート名が、列Bにはデータが配置されます。また、すべての変数に宣言を追加しました。

Public Sub extractCol() 

'Find FF&E Section, Add 3 rows and Identify relevant columns. 

Dim rFind As Range, CRange As String, ERange As String, KRange As String, MRange As String 
Dim ws As Worksheet 
Dim NewBook As Workbook 
Dim NumRange As Long 

Set NewBook = Workbooks.Add ' Open new Workbook 

For Each ws In ThisWorkbook.Worksheets 
    With ws 
     Set rFind = .Range("A:A").Find(What:="FF&E", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False) 
     If Not rFind Is Nothing Then 
      NumRange = rFind.Row + 3 ' Find FF&E line and add three 
      CRange = "C" & NumRange & ":" & "C" & NumRange + 100 ' Define First 100 Lines in Column C 
      ERange = "E" & NumRange & ":" & "E" & NumRange + 100 ' Define First 100 Lines in Column E 
      KRange = "K" & NumRange & ":" & "K" & NumRange + 100 ' Define First 100 Lines in Column K 
      MRange = "M" & NumRange & ":" & "M" & NumRange + 100 ' Define First 100 Lines in Column M 

      Set range1 = Union(.Range(CRange), .Range(ERange), .Range(KRange), .Range(MRange)) ' Combine individual column ranges in to one selection 
      range1.Copy ' Copy new combined range 
      NewBook.Sheets(1).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues ' Paste to new Workbook 
      NewBook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).Resize(range1.Rows.Count).Value = FindRoom(ws) 
     End If 
    End With 
Next ws 

End Sub 

Function FindRoom(ws As Worksheet) 

    shtName = ws.Name 

    Dim arr() As String 
    arr = VBA.Split(shtName, " ") 

    xCount = UBound(arr) 
    If xCount < 1 Then 
     FindRoom = "" 
    Else 
     FindRoom = arr(xCount) 
    End If 
End Function