Copying duplicating issue-CodePudding

i wrote the next code to copy a certain worksheet from my active workbook to multiple woorkbooks but it keeps duplicating the copies,thats my first problem, the next one i want that code to effect the folder and subfolders inside it how to do it. the code is:

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

as pay is the worksheet and the folder is my targeted folder .

CodePudding user response：

Please, use the next function, which will return an array of all files matching the ".xls*" extension criteria:

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

Then use it in your code in the next way:

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(ThisWorkbook.Path & "\", "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

When the above code will stop on the line Debug.Print El, run it line by line, pressing F8 and see what happends. If ie work as you need, please comment the code line in discussion and press F5 to run all of it.

Please, send some feedback after testing it.

CodePudding user response：

Add Worksheet to Multiple Files

This will copy an active workbook's worksheet to all relevant (.xlsx) files in a folder and all of its subfolders (/s).
It will skip the files already containing the worksheet.
If the code is in the workbook containing the worksheet (Pay), replace ActiveWorkbook with 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