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

Question

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

但我只想从 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

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