将多个工作合并为一个，并且只想从每个工作表中复制 2 行

Question

我创建了一个宏，将所有工作簿合并到一个Excel中，并从每个工作表中复制其全部数据。

但我只想从每个合并表中复制 2 行，即 A2 和 A3 行。

由于我对 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

但是，我不明白为什么您复制了所有工作表，只是为了最终删除它们。在工作簿之间复制值似乎更有效。也许我错过了什么。