複数のワークを1つに統合し、各ワークシートから2行だけをコピーしたい

Question

すべてのワークブックを統合して各ワークシートのデータ全体をコピーするマクロを作成しました。

しかし、私は行A2とA3である各統合シートから2行だけコピーしたいと思います。

私はVBAではあまりよくありませんが、このマクロはさまざまなソースから作成しました。 助けてください。

Sub CombilnedWorkBook_and_Sheets() 
Dim J As Integer 
Dim ws As Worksheet 
Dim varFieldName   As Variant 
Dim lngLoop     As Long 
Dim rngFound    As Range 
Dim rngCopy     As Range 
Dim lngLastRow    As Long 
Dim lngLastRow1    As Long 
Dim lngCol     As Long 
Dim wksTarget    As Worksheet 

Application.DisplayAlerts = False 

Set wksTarget = ThisWorkbook.Worksheets("Consolidated") 

varFieldName = Array("Patient Name", "DOB", "Admit_date", "Discharge_date", "Primary_DX_Code", "BPS PDF", "Consultation Doc", "Discharge Agreement", "EMF PDF", "Financial PDF", "ID & Insurance Card", "Lab Report PDF", "Legal History", "Medical Docs PDF", "Progress Notes PDF", "Pass Documentation", "Treatment Agreement", "Utilization Review", "User") 

Path = Sheet1.Range("C9").Value 
Filename = Dir(Path & "*.xlsx") 

    Do While Filename <> "" 
    Workbooks.Open Filename:=Path & Filename, ReadOnly:=True 
     For Each Sheet In ActiveWorkbook.Sheets 
     Sheet.Copy After:=ThisWorkbook.Sheets(1) 
     Next Sheet 
    Workbooks(Filename).Close savechanges:=False 
    Filename = Dir() 
    Loop 

    wksTarget.Range("a1").CurrentRegion.Offset(1).ClearContents 


     For J = 2 To Sheets.Count 
      lngLastRow1 = wksTarget.Cells(wksTarget.Rows.Count, "A").End(xlUp).Row + 1 
      Sheets(J).Activate 
      For lngLoop = 0 To UBound(varFieldName) 
      Set rngFound = Range("A1").EntireRow.Find(varFieldName(lngLoop)) 
      If Not rngFound Is Nothing Then 
       lngCol = rngFound.Column 
       lngLastRow = ActiveSheet.Cells(Rows.Count, lngCol).End(xlUp).Row 

       With ActiveSheet.Range("A1").CurrentRegion.Columns(lngCol) 
        Set rngCopy = .Offset(1).Resize(.Rows.Count - 1) 
       End With 
      rngCopy.Copy Destination:=wksTarget.Cells(lngLastRow1, lngLoop + 1) 

        Set rngFound = Nothing 
        Set rngCopy = Nothing 
        lngCol = 0 
        lngLastRow = 0 
      End If 
      Next lngLoop 
     Next 

    Sheets(1).Select 

    Columns("A:Z").Select 
    Selection.EntireColumn.AutoFit 

    Application.DisplayAlerts = False 
      For Each ws In Worksheets 
      If ws.Name <> "Consolidated" And ws.Name <> "Run Macro" Then ws.Delete 
      Next 

      Application.DisplayAlerts = True 
      Application.ScreenUpdating = False 
    MsgBox "File has been coppied Successfully" 

End Sub 

Answer 1

以下は、あなたが望むことをしていますか？モバイルで書かれた不正な書式設定や字下げには申し訳ありません。

Option explicit 
Sub CombilnedWorkBook_and_Sheets() 
'Dim J As long' 


Dim lngLoop     As Long 
Dim rngFound    As Range 
'Dim rngCopy     As Range' 
Dim lngLastRow    As Long 
Dim lngLastRow1    As Long 
Dim lngCol     As Long 
Dim wksTarget    As Worksheet 

Application.screenupdating = false 

Set wksTarget = ThisWorkbook.Worksheets("Consolidated") 

Dim varFieldName   As Variant 

varFieldName = Array("Patient Name", "DOB", "Admit_date", "Discharge_date", "Primary_DX_Code", "BPS PDF", "Consultation Doc", "Discharge Agreement", "EMF PDF", "Financial PDF", "ID & Insurance Card", "Lab Report PDF", "Legal History", "Medical Docs PDF", "Progress Notes PDF", "Pass Documentation", "Treatment Agreement", "Utilization Review", "User") 

Path = Sheet1.Range("C9").Value 
Filename = Dir(Path & "*.xlsx") 

Dim ws As Worksheet 

' Code below loops through worksheets only, will ignore sheets/charts' 

    Do While len(Filename) > 0 
Dim wb as Workbook 

     Set wb = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True) 
With wb 
     For Each ws In .worksheets 
     ws.Copy After:=ThisWorkbook.Sheets(1) 
     Next ws 
    .Close savechanges:=False 
End with 
Set wb = nothing 
    Filename = Dir() 


    Loop 
    wksTarget.Range("a1").CurrentRegion.Offset(1).ClearContents 

    For each ws in wkstarget.parent.worksheets 
       lngLastRow1 = wksTarget.Cells(wksTarget.Rows.Count, "A").End(xlUp).Row + 1 

       For lngLoop = lbound(varfieldname) To UBound(varFieldName) 

    With ws 
       Set rngFound = .Range("A1").EntireRow.Find(varFieldName(lngLoop),,xlvalues,xlwhole,xlbyrows,xlnext) 

       If Not rngFound Is Nothing Then 
        lngCol = rngFound.Column 
        lngLastRow = .Cells(Rows.Count, lngCol).End(xlUp).Row 

         .Range(.cells(2,lngcol),.cells(3,lngcol)).Copy Destination:=wksTarget.Cells(lngLastRow1, lngLoop + 1) 

         Set rngFound = Nothing 
         'Set rngCopy = Nothing' 
         lngCol = 0 
         lngLastRow = 0 
       End If 
    End with 
       Next lngLoop 
      Next ws 

     Wkstarget.parent.workSheets(1).Columns("A:Z").EntireColumn.AutoFit 

     Application.DisplayAlerts = False 
       For Each ws In wkstarget.parent.Worksheets 
       If ws.Name <> "Consolidated" And ws.Name <> "Run Macro" Then ws.Delete 
       Next ws 
       Application.DisplayAlerts = True 

       Application.ScreenUpdating = False 
     MsgBox "File has been coppied Successfully" 

    End Sub 

しかし、すべてのワークシートをコピーした理由はわかりませんが、最後に削除するだけです。ワークブック間で値をコピーしたばかりの方が効率的だと思われます。たぶん私は何かが欠けているでしょう。