复制复制问题

Question

我编写了下一个代码，将某个工作表从我的活动工作簿复制到多个工作簿，但它不断复制副本，这是我的第一个问题， 下一个我希望该代码影响其中的文件夹和子文件夹如何做到这一点。 代码是：

Option Explicit
Public Sub CopySheetToAllWorkbooksInFolder()
    Dim sourceWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim destinationWorkbook As Workbook
    Dim folder As String, filename As String
    'Worksheet in active workbook to be copied as a new sheet to the destination workbook
    Set sourceWorkbook = ActiveWorkbook
    Set sourceSheet = sourceWorkbook.Worksheets("pay")
    'Folder containing the destination workbooks
    folder = "J:\2021\hager\test\"
    filename = Dir(folder & "*.xlsx", vbNormal)
    While Len(filename) <> 0
        Debug.Print folder & filename
        Set destinationWorkbook = Workbooks.Open(folder & filename)
        sourceSheet.Copy after:=destinationWorkbook.Sheets(1)
        destinationWorkbook.ChangeLink Name:=sourceWorkbook.Name, NewName:=destinationWorkbook.Name
        destinationWorkbook.Close True
        filename = Dir()  ' Get next matching file
    Wend
End Sub

因为付款是工作表，文件夹是我的目标文件夹。

Answer 1

将工作表添加到多个文件

• 这会将活动工作簿的工作表复制到文件夹及其所有子文件夹 (/s) 中的所有相关 (.xlsx) 文件中。
• 它将跳过已经包含工作表的文件。
• 如果代码在包含工作表 (Pay) 的工作簿中，请将 ActiveWorkbook 替换为 ThisWorkbook。

Option Explicit

Sub CopySheetToAllWorkbooksInFolder()
    Const ProcName As String = "CopySheetToAllWorkbooksInFolder"
    On Error GoTo ClearError
    
    Const dFolderPath As String = "J:\2021\hager\test\"
    Const dFilePattern As String = "*.xlsx"
    Const swsName As String = "Pay"
    
    Dim fCount As Long
    
    Dim dFilePaths() As String
    dFilePaths = ArrFilePaths(dFolderPath, dFilePattern)
    If UBound(dFilePaths) = -1 Then Exit Sub ' no files found
    
    Dim swb As Workbook: Set swb = ActiveWorkbook ' ThisWorkbook ' 
    Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
    
    Dim dwb As Workbook
    Dim n As Long
    
    For n = 0 To UBound(dFilePaths)
        Debug.Print "Opening... " & dFilePaths(n)
        Set dwb = Workbooks.Open(dFilePaths(n))
        If Not SheetExists(dwb, swsName) Then
            sws.Copy After:=dwb.Sheets(1)
            'dwb.ChangeLink swb.Name, dwb.Name ' doesn't work for me
            fCount = fCount + 1
            Debug.Print "Worksheet added to... " & fCount & ". " & dFilePaths(n)
        End If
        dwb.Close SaveChanges:=True
    Next n
    
    MsgBox "Worksheet inserted in " & fCount & " workbook(s).", vbInformation

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
        & "    " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the file paths of the files of a folder in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*.*", _
    Optional ByVal DirSwitches As String = "/s/b/a-d") _
As Variant
    Const ProcName As String = "ArrFilePaths"
    On Error GoTo ClearError
    
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
    ExecString = "%comspec% /c Dir """ _
        & FolderPath & FilePattern & """ " & DirSwitches
    Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
        .Exec(ExecString).StdOut.ReadAll, vbCrLf)
    If UBound(arr) > 0 Then
        ReDim Preserve arr(0 To UBound(arr) - 1)
    End If
    ArrFilePaths = arr

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
        & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a boolean indicating wether a sheet, defined
'               by its name ('SheetName'), exists in a workbook ('wb').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function SheetExists( _
    ByVal wb As Workbook, _
    ByVal SheetName As String) _
As Boolean
    On Error GoTo ClearError

    Dim Sh As Object: Set Sh = wb.Sheets(SheetName)
    SheetExists = True
    
ProcExit:
    Exit Function
ClearError:
    Resume ProcExit
End Function

Answer 2

这将遍历文件夹和子文件夹中的工作簿。如果 pay 表不存在，它只会复制它。

Option Explicit

Public Sub CopySheetToAllWorkbooksInFolder()

    Const WS_NAME = "pay"
    Const folder = "J:\2021\hager\test\" ' destination workbooks

    Dim wbSrc As Workbook, wbDest As Workbook
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim FSO As Object, ts As Object
    Dim flds As Collection, fld As Object, f As Object
    Dim i As Long, n As Long, bExists As Boolean, logfile As String
    
    ' logfile
    logfile = Format(Now, "yyyyddmm_HHMMSS") & "_log.txt"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.createTextFile(logfile)
    
    Set wbSrc = ActiveWorkbook
    Set wsSrc = wbSrc.Sheets(WS_NAME)
    Set flds = New Collection
    
    If FSO.FolderExists(folder) Then
    
      ' collection of folders and subfolders
       Call GetFolders(FSO, folder, flds)
       
       'scan folders
       Application.ScreenUpdating = False
       For i = 1 To flds.Count
            ts.writeLine "---- Folder = " & flds(i)
            ' scan folder for files
            For Each f In flds(i).Files
               
                If f.Name Like "*.xlsx" Then
                    Set wbDest = Workbooks.Open(f.Path)
                    
                    ' check if sheet already exists
                    bExists = False
                    For Each wsDest In wbDest.Sheets
                        If wsDest.Name = WS_NAME Then
                            bExists = True
                            Exit For
                        End If
                    Next
             
                    ' copy sheet if not exists
                    If bExists = False Then
                        wsSrc.Copy after:=wbDest.Sheets(1)
                        wbDest.ChangeLink Name:=wbSrc.Name, NewName:=wbDest.Name
                        wbDest.Close savechanges:=True
                        n = n + 1
                        ts.writeLine f.Path & " inserted " & WS_NAME
                    Else
                        wbDest.Close savechanges:=False
                        ts.writeLine f.Path & " existing sheet " & WS_NAME
                    End If
                Else
                    ts.writeLine f.Path & " Skipped"
                End If
            Next
        Next
        MsgBox n & " sheets inserted see " & logfile, vbInformation
    Else
        MsgBox "Folder : " & folder, vbCritical, "Folder not found"
    End If
    ts.Close
    Application.ScreenUpdating = True   
End Sub

Sub GetFolders(FSO, s As String, ByRef flds)
    Dim fld As Object
    Set fld = FSO.getfolder(s)
    flds.Add fld
    For Each fld In fld.subfolders
        Call GetFolders(FSO, fld.Path, flds) ' recurse
    Next
End Sub

Answer 3

请使用下一个函数，它将返回一个包含所有符合“.xls*”扩展名条件的文件的数组：

Private Function allFiles(strFold As String, Optional ext As String = "") As Variant 'super, super fast...
  Dim arr
  arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir """ & strFold & """ /b /s").StdOut.ReadAll, vbCrLf), "\")
  If ext <> "" Then
    Dim arrFin, arrExt, El, i As Long
    ReDim arrFin(UBound(arr))
      For Each El In arr
         arrExt = Split(El, ".")
         If arrExt(UBound(arrExt)) Like ext Then
             arrFin(i) = El: i = i + 1
         End If
      Next El
      ReDim Preserve arrFin(i - 1)
      allFiles = arrFin
  Else
      allFiles = arr
  End If
End Function

然后在你的代码中用下一种方式：

Public Sub CopySheetToAllWorkbooksInFolder()
    Dim sourceWorkbook As Workbook, sourceSheet As Worksheet, destinationWorkbook As Workbook
    Dim folder As String, arr, El
    
    'Worksheet in active workbook to be copied as a new sheet to the destination workbook
    Set sourceWorkbook = ActiveWorkbook
    Set sourceSheet = sourceWorkbook.Worksheets("pay")
    'Folder containing the destination workbooks
    folder = "J:\2021\hager\test\"
    arr = allFiles(folder, "xls*")
    For Each El In arr
        Debug.Print El: Stop 'run the code line by line pressing F8
        Set destinationWorkbook = Workbooks.Open(El)
        sourceSheet.copy After:=destinationWorkbook.Sheets(1)
        destinationWorkbook.ChangeLink Name:=sourceWorkbook.Name, newName:=destinationWorkbook.Name
        destinationWorkbook.Close True
    Next El
End Sub

当上面的代码将停止在Debug.Print El 行时，逐行运行它，按下F8 看看会发生什么。如果 ie 按您的需要工作，请在讨论中评论代码行并按F5 运行所有代码。

请在测试后发送一些反馈。