從多個工作簿復制粘貼一行到主工作簿

Question

我有以下代碼來執行某些操作。 而我需要添加一個額外的操作，即從多個工作簿中復制第 2 行中名為“站點創建模板（項目）”的第 10 行，如下所示。

我已經嘗試了網絡上可用的其他幾種可能的組合，但它返回錯誤的值或只是空白。

誰可以幫我這個事？

PS：我只是 VBA 的初學者。

    Sub copyDataFromMultipleWorkbooksIntoMaster()

Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String

Dim masterBook As Workbook
Dim sourceBook As Workbook

Dim insertRow As Long
Dim copyRow As Long

' add variables for blank check
Dim checkRange As Range, R As Range

insertRow = 22
Set masterBook = ThisWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")

        With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder with source files"
        If Not .Show = 0 Then
            BrowseFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False


    Set oFolder = FSO.getfolder(BrowseFolder)

    masterBook.Sheets("Service Order Template").Cells.UnMerge


    For Each FileItem In oFolder.Files

       If FileItem.Name Like "*.xls*" Then

        Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)

       Set sourceBook = Workbooks(FileItem.Name)

           With sourceBook.Sheets("Service Order Template")
               .Cells.UnMerge
               copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
               Range(.Cells(22, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)

               ' copy additional needed range D5 : D18 from source to range D5 on master
               Range(.Cells(5, 4), .Cells(18, 4)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(5, 4)

               Application.CutCopyMode = False
               .Parent.Close saveChanges:=False
          End With
        insertRow = masterBook.Sheets("Service Order Template").Cells(Rows.Count, 18).End(xlUp).Row + 2
       End If
    Next

    With masterBook.Sheets("Service Order Template")
        ' if you don't need to highlight the whole row - remove the ".EntireRow" part ?---?---?----?
        Range(.Cells(20, 18), .Cells(Rows.Count, 18).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow
    End With


    Application.ScreenUpdating = True
    Application.DisplayAlerts = False
    Application.Dialogs(xlDialogSaveAs).Show ThisWorkbook.Name, 51


End Sub

Answer 1

我不確定你在哪個部分遇到了問題，但試試這個

Option Explicit

Sub CopyDataFromMultipleWorkbooksIntoMaster()

    Const TEMPLATE = "Service Order Template"
    Const SITE_TEMPLATE = "Site Creation Template(Project)"

    Dim FSO As Object
    Dim BrowseFolder As String
    Dim oFolder As Object

    ' select folder
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder with source files"
        If Not .Show = 0 Then
            BrowseFolder = .SelectedItems(1)
        Else
            MsgBox "Cancelled selection", vbCritical
            Exit Sub
        End If
    End With
    'Debug.Print "BrowseFolder = " & BrowseFolder

    Dim wbMaster As Workbook, wsMaster As Worksheet
    Dim wbSource As Workbook, wsSource As Worksheet, rngSource As Range
    Dim f As Object, fname As String
    Dim lastSrcRow As Long
    Dim insertRow1 As Long, insertRow2 As Long, count As Long

    Set wbMaster = ThisWorkbook
    Set wsMaster = wbMaster.Sheets(TEMPLATE)

    insertRow1 = 22
    insertRow2 = 1 ' start of row 10 copies on sheet 2 of master

    Set oFolder = FSO.getfolder(BrowseFolder)
    count = 0

    ' scan files
    For Each f In oFolder.Files

        If f.Name Like "*.xls*" Then

            fname = BrowseFolder & Application.PathSeparator & f.Name
            'Debug.Print fname

            Set wbSource = Workbooks.Open(fname, False, True) ' open no link update, read-only
            Set wsSource = wbSource.Sheets(TEMPLATE)

            lastSrcRow = wsSource.Cells(Rows.count, 18).End(xlUp).Row

            Set rngSource = wsSource.Range("A22:AS" & lastSrcRow) ' AS=col45
            Debug.Print f.Name, wsSource.Name, rngSource.Address

            rngSource.Copy wsMaster.Cells(insertRow1, 1)
            insertRow1 = insertRow1 + rngSource.Rows.count + 1

            ' copy additional needed range D5 : D18 from source to range D5 on master
            wsSource.Range("D5:D18").Copy wsMaster.Range("D5")

            'copying row 10 from sheet 2 with name "Site Creation Template(Project)"
            wbSource.Sheets(SITE_TEMPLATE).Rows(10).EntireRow.Copy wbMaster.Sheets(2).Range("A" & insertRow2)
            insertRow2 = insertRow2 + 1

            wbSource.Close False
            count = count + 1
        End If
    Next

    ' if you don't need to highlight the whole row - remove the ".EntireRow" part ?---?---?----?
    wsMaster.Range("R20:R" & insertRow1 - 1).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow

    End
    MsgBox count & " files processed", vbInformation
End Sub