Question

我创建了一个宏，它将一个excel中的所有工作簿合并，并从每个工作表中复制整个数据。

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

由于我在VBA方面不是很好，但是我已经从各种来源创建了这个宏。请帮忙。

Map

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

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

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

1 个答案: