通過多個工作表的數據提取

Question

我完全是VBA的新手，我試圖編寫一個excel模塊來提取工作簿的每個工作薄上的特定部分，並將它們格式化並輸出到一張新的工作簿上。

到目前爲止，我有這個;

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 

這太好了，因爲它提取了我想要正確的位，但它只做當前工作表。我如何循環執行所有表單？

其次，我想將所有結果粘貼到同一張紙上？

最後，我有下面的腳本提取表格名稱和格式。理想情況下，我想在上面的輸出中添加一列，根據來自哪張表來顯示此數據。

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