Copying duplicating issue - excel

Question

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 .

Answer 1

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

Answer 2

This loops through workbooks in the folder and subfolders. It only copies the pay sheet if it doesn't exist.
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

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(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
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.