Copy a specific worksheet to only certain files in a folder

[rholdren]

Hello Everyone . I am looking for a way to copy a worksheet to into specific workbooks in a certain folder.
The workbooks currently do not have this worksheet in them so I would just like to copy the worksheet from the template
into the files on the list. I have a list of files in column A that include the path of each file (the ones without the worksheet).
The open workbook has a worksheet named "Census". The Census worksheet just has headings in row 1.
I would like just open each file on the list and insert a new worksheet named Census.
The template file is Excel 365 but the receiving files are excel 97-2000 so I can't just do a copy/move because I will get an
incompatability error. So my thought is I could use something similar to what I was using to copy and paste data from a file in column A
to a recediving file listed in column B but I am just not sure how to. Any help would be greatly appreciated.

What I have been working with is listed below.

Receiving File (Column A) (In Column B is currently the file the data listed in Column A below would bo to)
S:\Automated Aggregate Detail\Aggregate Workspace\THE PINE SCHOOL, INC.76450080 Mthly Agg 1010 3-1-2022 14786.xls
S:\Automated Aggregate Detail\Aggregate Workspace\HOMESTEAD FINANCIAL MORTGAGE76415401 Mthly Agg 1010 3-1-2022 14782.xls
S:\Automated Aggregate Detail\Aggregate Workspace\E-Z BEL CONSTRUCTION, LLC76415516 Mthly Agg 0710 7-1-2022 14895.xls

Sub Post_10Months()


Range("R1").Value = "Process Running"

Call ShowStart

Application.Wait (VBA.Now + VBA.TimeValue("0:00:3"))

'
Application.ScreenUpdating = False



Sheets("10MONTHS").Select
'
Dim columnX As Range, cell As Range
Set columnX = Range("A2:A1500")




Dim path1, path2 As String
Dim FileOpen As String
Dim ifilenum As Long

For Each cell In columnX

ChDir "S:\ReportingDepartment\ReportingAnalyst\Projects\REX\Original Report Data"

'copies current cell value into path1
path1 = cell.Value
If Dir(path1) = "" Then
Sheets("Dashboard").Select
Range("A2").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell = path1 & " - NOT FOUND"
GoTo NoReceivingFile
End If
Workbooks.Open Filename:=path1

Range("A2:M11").Select
Selection.Copy

Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True


ChDir "S:\ReportingDepartment\ReportingAnalyst\Projects\REX\Reports To Be Sent"

'copies the vaule of the offset to thr right cell into path2
path2 = cell.Offset(0, 1).Value

On Error Resume Next
ifilenum = FreeFile()
Open path2 For Input Lock Read As #ifilenum
Close #ifilenum
Application.CutCopyMode = False
If Err.Number <> 70 Then 'file is close
Workbooks.Open Filename:=path2
Sheets("Detail").Select
Range("A5:M14").Select
Application.DisplayAlerts = False
ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
DisplayAsIcon:=False, NoHTMLFormatting:=True
Application.DisplayAlerts = True
Range("B5:B17").Select
Selection.NumberFormat = "0"
Columns("B:B").EntireColumn.AutoFit
Range("A3").Select
Sheets("Summary").Select
ActiveWorkbook.Save
ActiveWindow.Close
Else

Sheets("Dashboard").Select

Range("A2").Select
'Range("d8").Value = path2
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.Value = path2
'ActiveCell.PasteSpecial Paste:=xlPasteValues


End If

NoReceivingFile:

Next cell
'
'
Exit Sub
Application.DisplayAlerts = False
Range("E3").Value = "Process Complete"


Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
Range("d8").Value = path2
ActiveCell.PasteSpecial Paste:=xlPasteValues


'
'
Resume Next ' go back to the line following the error



Call add_posted10
Call ShowEnd

End Sub

 

[HaHoBe]

Hi rholdren,

from what I read from your request the code to insert a sheet into the selected files may look like this (please test this code on copies first before dealing with the real data):

Sub CopySheetCensus()
'https://www.mrexcel.com/board/threads/copy-a-specific-worksheet-to-only-certain-files-in-a-folder.1219249/
  Dim wbThis          As Workbook
  Dim ws2Copy         As Worksheet
  Dim wbk2Open        As Workbook
  Dim wsTarget        As Worksheet
  Dim rngWork         As Range
  Dim rngCell         As Range
  Dim blnContinue     As Boolean
  Dim lngColumns      As Long
  
  'if an error is raised go to the error handler and get out of the procedure leaving information in the Immediate Window
  On Error GoTo err_here
  'Set objects to ThisWorkbook
  Set wbThis = ThisWorkbook
  Set ws2Copy = wbThis.Sheets("Census")
  Set rngCell = ws2Copy.Range("A2")
  'get the number of columns as header and limit this to a max of 256
  lngColumns = WorksheetFunction.Min(ws2Copy.Cells(1, ws2Copy.Columns.Count).End(xlToLeft).Column, 256)
  
  Application.ScreenUpdating = False
  With wbThis.Sheets("10MONTHS")
    'set the area to work on. If there are empty cells specialcells may be used to work on only values
    Set rngWork = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    For Each rngCell In rngWork
      'set Boolean to True to continue
      blnContinue = True
      'if no file with this name is found
      If Dir(rngCell.Value) = "" Then
        'note in cell
        rngCell.Value = rngCell.Value & " - NOT FOUND"
        'no further actrion for this cell vsalue
        blnContinue = False
      End If
      If blnContinue Then
        'open workbook
        Set wbk2Open = Workbooks.Open(Filename:=rngCell.Value)
        'add a sheet in opened workbook
        Set wsTarget = wbk2Open.Sheets.Add
        'rename sheet
        wsTarget.Name = "Census"
        'copy the headers over
        wsTarget.Range("A1").Resize(1, lngColumns).Value = ws2Copy.Range("A1").Resize(1, lngColumns).Value
        'close and save workbook
        wbk2Open.Close True
        'set objects free
        Set wsTarget = Nothing
        Set wbk2Open = Nothing
      End If
    Next rngCell
  End With
  
end_here:
  'setting objects free, turning screen updating back on, leaving sub
  Set rngWork = Nothing
  Set ws2Copy = Nothing
  Set wbThis = Nothing
  Application.ScreenUpdating = True
  Exit Sub
  
err_here:
    'leave information in the Immediate Window instead of displaying a modal MsgBox
    Debug.Print "---===---" & vbCrLf & "Error raised: " & Now & _
        vbCrLf & "Error raised in cell: " & rngCell.Address(0, 0) & _
        vbCrLf & "Error Number: " & Err.Number & _
        vbCrLf & "Error Description: " & Err.Description
    MsgBox "An error occurred, more information in the Immediate Window / VBE", vbInformation, "Could not finish procedure properly"
    Resume end_here
  
End Sub

One note (at least) to your code: once you have placed the line

Exit Sub

no further commands from the procedure will be prosecuted, these two words mean what they stand for: the end of that procedure (unless you use them together with a boolean to check or inside an If or Select Case).

And maybe next time use code tags to display your code - white spaces will be displayed if used and copying to the clipboard is just one click.

Ciao,
Holger

 

[HaHoBe]

Hi rholdren,

if you choose to run the above code more than once there are some changes to consider. I would not add "Not Found" directy to the contents in Column A but have 2 new columns to gather the information about the status (when the file was not found) as well as at which date the template was added. The working range will be determined from the empty cells in the Done column using an offset to work on Column A. The constant clngColDiffToColA needs to hold the correct difference between Column A (where the data should work) and the column for Done (in my sample this is Column D meaning that the Offset between Done And Column A is 3).

Sub MrE1612108_CopySheetCensus_V2()
'https://www.mrexcel.com/board/threads/copy-a-specific-worksheet-to-only-certain-files-in-a-folder.1219249/
  Dim wbThis          As Workbook
  Dim ws2Copy         As Worksheet
  Dim wbk2Open        As Workbook
  Dim wsTarget        As Worksheet
  Dim rngWork         As Range
  Dim rngCell         As Range
  Dim blnContinue     As Boolean
  Dim lngColumns      As Long
  
  Const cstrNotFoundCol       As String = "C"           'change to suit
  Const cstrDoneCol           As String = "D"           'change to suit
  Const cstrTemplateName      As String = "Census"      'name of template to copy
  Const clngColDiffToColA     As Long = 3               'difference in numbers between ColA (1) and ColD (4)
                                                        'change here to suit
                                                        '!!! the real number for the difference is needed for the code to work
  
  'if an error is raised go to the error handler and get out of the procedure leaving information in the Immediate Window
  On Error GoTo err_here
  'Set objects to ThisWorkbook
  Set wbThis = ThisWorkbook
  Set ws2Copy = wbThis.Sheets(cstrTemplateName)
  Set rngCell = ws2Copy.Range("A1")
  'get the number of columns as header and limit this to a max of 256
  lngColumns = WorksheetFunction.Min(ws2Copy.Cells(1, ws2Copy.Columns.Count).End(xlToLeft).Column, 256)
  
  Application.ScreenUpdating = False
  With wbThis.Sheets("10MONTHS")
    'check if there are blanks on column for Done, if none are found no new data has been added
    If WorksheetFunction.CountBlank(.Range(.Cells(2, cstrDoneCol), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, cstrDoneCol))) > 0 Then
      'set the headers
      .Cells(1, cstrNotFoundCol).Value = "Status"
      .Cells(1, cstrDoneCol).Value = "Done"
      .Cells(1, cstrNotFoundCol).Resize(1, 2).Font.Bold = True
      'set the area to work on. We spot the area for the Done Column and offset the area to column A.
      '/// clngColDiffToColA must be adjusted properly in order to for teh code to work
      Set rngWork = .Range(.Cells(2, cstrDoneCol), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, cstrDoneCol)) _
                            .SpecialCells(xlCellTypeBlanks).Offset(, -clngColDiffToColA)
      For Each rngCell In rngWork
        'set Boolean to True to continue
        blnContinue = True
        'if no file with this name is found
        If Dir(rngCell.Value) = "" Then
          'note in cell
          rngCell.Offset(0, clngColDiffToColA - 1).Value = "NOT FOUND - " & Date
          'no further action for this cell value
          blnContinue = False
        End If
        If blnContinue Then
          'clear any existing text from cell
          rngCell.Offset(0, clngColDiffToColA - 1).Value = vbNullString
          'open workbook
          Set wbk2Open = Workbooks.Open(Filename:=rngCell.Value)
          'check if a copy of template is missing
          If Not Evaluate("ISREF('" & cstrTemplateName & "'!A1)") Then
            'add a sheet in opened workbook
            Set wsTarget = wbk2Open.Sheets.Add
            'rename sheet
            wsTarget.Name = cstrTemplateName
            'copy the headers over
            wsTarget.Range("A1").Resize(1, lngColumns).Value = ws2Copy.Range("A1").Resize(1, lngColumns).Value
          End If
          'close and save workbook
          wbk2Open.Close True
          'set objects free
          Set wsTarget = Nothing
          Set wbk2Open = Nothing
          rngCell.Offset(0, clngColDiffToColA).Value = Now
        End If
      Next rngCell
    End If
    .Cells(1, cstrNotFoundCol).Resize(1, 2).EntireColumn.AutoFit
  End With
  
end_here:
  'setting objects free, turning screen updating back on, leaving sub
  Set rngWork = Nothing
  Set ws2Copy = Nothing
  Set wbThis = Nothing
  Application.ScreenUpdating = True
  Exit Sub
  
err_here:
    'leave information in the Immediate Window instead of displaying a modal MsgBox
    Debug.Print "---===---" & vbCrLf & "Error raised: " & Now & _
        vbCrLf & "Error raised in cell: " & rngCell.Address(0, 0) & _
        vbCrLf & "Error Number: " & Err.Number & _
        vbCrLf & "Error Description: " & Err.Description
    MsgBox "An error occurred, more information in the Immediate Window / VBE", vbInformation, "Could not finish procedure properly"
    Resume end_here
  
End Sub

Ciao,
Holger

 

[rholdren]

Thanks for your help. I really appreciate it. We can consider this closed. Thank you

 

[HaHoBe]

Hi rholdren,

you could have a look at Mark as Solution and act accordingly. Thanks for the update and feedback.

Holger