Question

我具有以下代码来执行某些操作。而我需要采取其他措施，从多个工作簿中复制工作表2中第10行的名称为“ Site Creation Template（Project）”，如下所示。

我尝试了网络上其他几种可能的组合，但返回的值错误或仅为空白。

有人可以帮我吗？

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

从多个工作簿复制粘贴一行到主工作簿

1 个答案: