여러 워크 시트에서 데이터 추출

Question

저는 VBA에 완전히 익숙하며 통합 문서의 각 시트에서 특정 섹션을 추출하여 서식을 지정하고 새 통합 문서에서 1 시트로 함께 출력하는 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 

정확하게는 wan't가 아닌 현재 시트 만 추출합니다. 모든 시트를 처리하려면 어떻게 반복합니까?

두 번째로 모든 결과를 같은 시트 아래에 붙여 넣으시겠습니까?

그리고 마지막으로 시트 이름을 추출하여 형식을 지정하는 아래 스크립트가 있습니다. 이상적으로 나는 출처 시트에 따라이 데이터를 표시 할 위의 출력에 열을 추가하려고합니다.

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