将图像和数据从多个源工作簿复制到单个工作簿的有效方法

Question

我使用下面的代码将图像从一个工作簿复制到另一个工作簿。代码打开源工作簿/工作表，复制图像，然后关闭工作簿。此过程重复多次。有没有更有效的方法来做到这一点？也许绕过了剪贴板？

我只需要为每个源工作簿/工作表复制一个图像(名为“图片4")和2-3个单元格值。我有7-8个源工作簿。

Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")     

srcWS.Pictures(4).Copy         
dstWS.Range("B7").PasteSpecial

Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")     

srcWS.Pictures(4).Copy         
dstWS.Range("G8").PasteSpecial

Answer 1

所以的快速解决方案在这里：关闭屏幕更新，然后再次打开它，然后我在我的代码中实现了一些时间测量来可视化这一点：

Option Explicit

Sub copy_images_original()

Dim dstWS As Worksheet
Set dstWS = ThisWorkbook.Sheets(1)
Dim srcWB As Workbook
Dim srcWS As Worksheet

Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS1.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")

srcWS.Pictures(4).Copy
dstWS.Range("B7").PasteSpecial
srcWB.Close

Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\testWS2.xlsx", True, True)
Set srcWS = srcWB.Sheets("sheetwithimage")

srcWS.Pictures(4).Copy
dstWS.Range("G8").PasteSpecial
srcWB.Close
End Sub

Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer

'*****************************
Call turn_app_off
Call copy_images_original
Call turn_app_on
'*****************************

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

Sub turn_app_off()
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With
End Sub
Sub turn_app_on()
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

现在有什么改进吗？你的srcWBs现在将被关闭，你的原始源代码没有这样做。

在我的场景中，执行时间从2秒缩短到1,4秒。所以你的代码运行速度提高了25%，不需要太多的努力。

希望你觉得我的建议足够公道。致以最诚意的问候

Answer 2

创建报告

• 我假设目标工作簿和包含此代码的工作簿ThisWorkbook相同。
• 调整常量部分中的值。
• 仅运行createReport过程。它正在调用函数getFilePathsInFolder。
• 由于ThisWorkbook将没有"xlsx"扩展名，所以语句If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then是多余的，但我保留它是因为有一天您可能会将文件扩展名更改为"xls*"，而此时代码可能会造成一些破坏。

抽象

• 它将在指定的文件夹中查找，并将所有.xlsx文件写入一个数组。它将遍历数组并打开每个工作簿，以复制由其索引指定的图片，然后将其粘贴并写入指定的单元格值到目标工作簿的指定位置，然后关闭每个源工作簿。

代码

Option Explicit

Sub createReport()
    
    Const ProcName As String = "createReport"
    On Error GoTo clearError

    ' Source
    Const Extension As String = "xlsx"
    Const srcName As String = "sheetwithimage"
    Const srcList As String = "A1,A2,A3" ' add more
    Const picIndex As Long = 1
    ' Destination
    Const dstName As String = "Sheet1"
    Const dstList As String = "B1,B2,B3" ' add more
    Const picAddress As String = "B7"
    Const colOffset As Long = 5
    
    ' Write file paths from Source Folder Path to File Paths array.
    Dim wbDst As Workbook: Set wbDst = ThisWorkbook
    Dim srcFolderPath As String: srcFolderPath = wbDst.Path
    Dim FilePaths As Variant
    FilePaths = getFilePathsInFolder(srcFolderPath, Extension)
    
    
    Dim srcCells() As String: srcCells = Split(srcList, ",")
    Dim dstCells() As String: dstCells = Split(dstList, ",")
    ' Use a variable for lower and upper if inside another loop.
    ' Split ensures that lower is 0, so no need for lower variable.
    Dim CellsUB As Long: CellsUB = UBound(srcCells) ' or 'Ubound(dstCells)'
    Dim dst As Worksheet: Set dst = wbDst.Worksheets(dstName)
    Dim dstFilePath As String: dstFilePath = wbDst.FullName
    
    ' Declare new variables occurring in the following loop.
    Dim wbSrc As Workbook
    Dim src As Worksheet
    Dim srcCount As Long
    Dim fp As Long
    Dim n As Long
    
    Application.ScreenUpdating = False
    
    ' We don't care if 'FilePaths' is zero, one or five-based, since we
    ' cannot use fp because of 'ThisWorkbook'; hence 'srcCount'.
    For fp = LBound(FilePaths) To UBound(FilePaths)
        ' We have to skip 'ThisWorkbook'. Using 'StrComp' with 'vbTextCompare'
        ' is a great way for comparing strings case-insensitively i.e. 'A=a'.
        ' '0' means it is a match.
        If StrComp(FilePaths(fp), dstFilePath, vbTextCompare) <> 0 Then
            Set wbSrc = Workbooks.Open(FilePaths(fp), True, True)
            Set src = wbSrc.Worksheets(srcName)
            src.Pictures(picIndex).Copy
            dst.Range(picAddress).Offset(, srcCount * colOffset).PasteSpecial
            For n = 0 To CellsUB ' 'Split'
                dst.Range(dstCells(n)).Offset(, srcCount * colOffset).Value _
                    = src.Range(srcCells(n)).Value
            Next n
            wbSrc.Close SaveChanges:=False
            srcCount = srcCount + 1
        End If
    Next fp
    
    ' Save and/or inform user.
    If srcCount > 0 Then
        dst.Range("A1").Select
        wbDst.Save
        Application.ScreenUpdating = True
        If srcCount = 1 Then
            MsgBox "Data from 1 workbook transferred.", vbInformation, "Success"
        Else
            MsgBox "Data from " & srcCount & " workbooks transferred.", _
                vbInformation, "Success"
        End If
    Else
        MsgBox "No matching workbooks found in folder '" & srcFolderPath _
            & "'!", vbCritical, "Fail"
    End If

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
    
End Sub

Function getFilePathsInFolder( _
    FolderPath As String, _
    Optional ByVal ExtensionPattern As String = "", _
    Optional ByVal FirstIndex As Long = 0) _
As Variant
    
    Const ProcName As String = "listFilePathsInFolder"
    On Error GoTo clearError
    
    With CreateObject("Scripting.FileSystemObject")
        Dim fsoFolder As Object
        Set fsoFolder = .GetFolder(FolderPath)
        Dim FilesCount As Long
        FilesCount = fsoFolder.Files.Count
        If FilesCount > 0 Then
            Dim n As Long
            n = FirstIndex - 1
            Dim OneD As Variant
            ReDim OneD(FirstIndex To FilesCount + n)
            Dim fsoFile As Object
            If ExtensionPattern = "" Then
                For Each fsoFile In fsoFolder.Files
                    n = n + 1
                    OneD(n) = fsoFile.Path
                Next fsoFile
                getFilePathsInFolder = OneD
            Else
                For Each fsoFile In fsoFolder.Files
                    If LCase(.GetExtensionName(fsoFile)) _
                            Like LCase(ExtensionPattern) Then
                        n = n + 1
                        OneD(n) = fsoFile.Path
                    End If
                Next fsoFile
                If n > FirstIndex - 1 Then
                    ReDim Preserve OneD(FirstIndex To n)
                    getFilePathsInFolder = OneD
                Else
                    Debug.Print "'" & ProcName & "': " _
                        & "No '" & ExtensionPattern & "'-files found."
                End If
            End If
        Else
            Debug.Print "'" & ProcName & "': " _
                & "No files found."
        End If
    End With

ProcExit:
    Exit Function

clearError:
    Debug.Print "'" & ProcName & "': Unexpected error!" & vbLf _
        & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
        & "        " & Err.Description
    Resume ProcExit

End Function