Try this
Code:
Sub TCall()
CopyAndPasteToMultipleWorkbooks "SourceSheetName", "J:J", "DestinationSheetName", "DestinationRangeAddress"
End Sub
Sub CopyAndPasteToMultipleWorkbooks(strFromSheet As String, strFromRange As String, strToSheet As String, strToRange As String)
Dim strFile As String
Dim strFileType As String
Dim strPath As String
Dim lngLoop As Long
Dim wbk As Workbook
strPath = "C:\ExcelFox"
strFileType = "Book*.xlsx" 'Split with semi-colon if you want to specify the file types. Example ->> "*.xls;*.doc"
For lngLoop = LBound(Split(strFileType, ";")) To UBound(Split(strFileType, ";"))
strFile = Dir(strPath & "\" & Split(strFileType, ";")(lngLoop))
Do While strFile <> ""
If strFile <> ThisWorkbook.Name Then
Set wbk = Workbooks.Open(strPath & "\" & strFile, False, True)
With wbk.Sheets(strToSheet)
ThisWorkbook.Worksheets(strFromSheet).Range(strFromRange).Copy .Range(strToRange)
.Parent.Close 1
End With
End If
Loop
Next lngLoop
strFile = vbNullString
strFileType = vbNullString
strPath = vbNullString
lngLoop = Empty
End Sub
Bookmarks