Adding A Sheet To Multiple Workbooks With A Macro

[rockyw]

I have about 200 workbooks that I would like to add a sheet to. The sheet I want to add is actually a JPEG I scanned and pasted on a new sheet. I named the sheet (Change Over Worksheet) Is there a way to add this sheet to the other 200 workbooks with a macro copying from another workbook with the new sheet added? All the workbooks are in the same folder and sheet 1 are all different in every workbook. I can do this manually one by one but it will take some time. Thanks

 

[ranman256]

start with the workbook sheet that has the jpg.
paste this code into the VBE macros
this code will open every workbook in the folder given in FixAllFiles(),
then open the next workbook and copy the source sheet (with Jpg) to the target workbook

Public Sub FixAllFiles()
FixAllFilesInDir "F:\Documents\"
End Sub


Private Sub FixAllFilesInDir(ByVal pvDir)
Dim FSO, oFolder, oFile, oRX
Dim sTxt As String, sFile As String
Dim wbSrc As Workbook, wbTarg As Workbook
On Error GoTo errGetFiles
Set wbSrc = ActiveWorkbook   'source wb with the jpeg.
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(pvDir)
If Right(pvDir, 1) <> "\" Then pvDir = pvDir & "\"
For Each oFile In oFolder.Files
  If InStr(oFile.Name, ".xls") > 0 Then            'import file here
      sFile = oFile
      Workbooks.Open sFile
      Set wbTarg = ActiveWorkbook
      
           'copy the jpg sheet to new workbook
        wbSrc.Activate
        wbSrc.ActiveSheet.Copy Before:=wbTarg.Sheets(1)
        wbTarg.Close True      
  End If
Next
endit:
Set oFile = Nothing
Set oFolder = Nothing
Set FSO = Nothing
MsgBox "Done"
Exit Sub
errGetFiles:
MsgBox Err.Description, , Err
Resume endit
Resume
End Sub

 

[rockyw]

I found this, will it work as written? Thanks

Option ExplicitPublic Sub CopySheetToAllWorkbooksInFolder()
Dim sourceSheet As Worksheet
Dim folder As String, filename As String
Dim destinationWorkbook As Workbook
'Worksheet in active workbook to be copied as a new sheet to the destination woorkbook
Set sourceSheet = ActiveWorkbook.Worksheets("Sheet1")
'Folder containing the destination workbooks
folder = "F:\temp\excel"
filename = Dir(folder & "*.xls", vbNormal)
While Len(filename) <> 0
Debug.Print folder & filename
Set destinationWorkbook = Workbooks.Open(folder & filename)
sourceSheet.Copy before:=destinationWorkbook.Sheets(1)
destinationWorkbook.Close True
filename = Dir() ' Get next matching file
Wend
End Sub

 

[rockyw]

Just seen your reply, I will try this ASAP. Thanks

 

[rockyw]

Hey Ranman 256, this works but before I run this on all 200 can this save as macro free without answering Yes each time and can the new see be after the one there now? I know, I'm asking a lot. Thanks

 

[rockyw]

I found the place to edit for after but I didn't get the save as part yet. Thanks