Rebuild a workbook with VBA

Question

I am trying to run the below VBA that I found online. The purpose of the code is to copy the data from all of the worksheets in a workbook to a different workbook. A couple key points:

1) I am trying to copy the data in all worksheets NOT the actual worksheets to the new workbook 2) The macro does a lot: makes sure you have a back-up file; creates a new worksheet (TargetWorkbook) and saves with the source workbook's name; etc. however, the most important part (and where I believe it is erroring) is copying the worksheets 3) I understand what is going on with the code but not savvy enough to make it work.

Sub Update_SmartView_Workbook()
' Copies sheets from a source workbook to new and current Excel target workbook to
' get rid of the "2003 or earlier backbone" that interferes with SmartView.
' Keyboard Shortcut: Ctrl+z
' Copyleft 2013 By MJ Henderson. No rights reserved. Free and worth every penny. 
' User assumes all risk. No warranties implied or otherwise.

    Dim ConfirmBackup As Integer
    Dim SourceWorkbook, TargetWorkbook As Workbook
    Dim SourceWorksheet As Worksheet
    Dim SourceWorkbookName As String

    ' User must make a backup before proceeding.
    ConfirmBackup = MsgBox("Have you made a backup copy of the source file?", vbYesNo, "Confirm Backup")
    If ConfirmBackup = vbNo Then
    MsgBox "Try again when you have a backup copy of the source file", vbOKOnly, "Backup Required"
    Exit Sub
    End If
    ' Find and open the source file
    Application.FindFile
    Set SourceWorkbook = ActiveWorkbook
    SourceWorkbookName = ActiveWorkbook.Name
    SourceWorkbookDirectoryPath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(SourceWorkbookName))

    ' Create a new target workbook in the same folder as the source workbook
    Workbooks.Add
    ActiveWorkbook.SaveAs _
    Filename:=SourceWorkbookDirectoryPath & "TargetWorkbook.xlsx", _
    FileFormat:=xlOpenXMLWorkbook, ConflictResolution:=True

    ' Copy each worksheet in SourceWorkbook to TargetWorkbook THIS IS WHERE THE FIX IS NEEDED
    SourceWorkbook.Activate
    For Each SourceWorksheet In SourceWorkbook.Worksheets
    SourceWorksheet.Cells.Copy
    Windows("TargetWorkbook.xlsx").Activate
    ActiveWindow.WindowState = xlNormal
    On Error Resume Next
    TargetWorkbook.Sheets(SourceWorksheet.Name).Delete
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    ActiveSheet.Name = SourceWorksheet.Name
    Application.CutCopyMode = cancel
    Next

    ' Close SourceWorkbook, rename SourceWorkbook with suffix "_OLD"
    SourceWorkbook.Activate
    SourceWorkbook.Saved = True
    SourceWorkbook.Close SaveChanges:=False
    Name SourceWorkbookDirectoryPath & SourceWorkbookName As SourceWorkbookDirectoryPath & SourceWorkbookName & "_OLD"

    ' Global replace to remove any references to old workbook. (Fixes interbook links.)
    Cells.Replace What:="[" & SourceWorkbookName & "]", _
    Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
    False, SearchFormat:=False, ReplaceFormat:=False

    ' Rename TargetWorkbook as SourceWorkbook's original name, delete TargetWorkbook
    TargetWorkbook.Activate
    ActiveWorkbook.SaveAs _
    Filename:=SourceWorkbookDirectoryPath & SourceWorkbookName, _
    FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close SaveChanges:=False
    Kill SourceWorkbookDirectoryPath & "TargetWorkbook.xlsx"

End Sub

I believe these lines are driving the error:

 Windows("TargetWorkbook.xlsx").Activate
 ActiveWindow.WindowState = xlNormal

The error I am getting is "Run Time Error 9 - Subscript out of Range"

Any idea on how to fix?

Answer 1

I would recommend to eliminate the activating if the sheet and workbooks; we do not need it. Just referencing the object is enough.

This is an untested code see how it goes you might need to change it a little bit to fit your needs.

Option Explicit

Sub Test()

Dim ConfirmBackup As Integer
Dim SourceWorkbook, TargetWorkbook As Workbook
Dim SourceWorksheet As Worksheet
Dim SourceWorkbookName As String
Dim SourceWorkbookDirectoryPath As String

' User must make a backup before proceeding.
ConfirmBackup = MsgBox("Have you made a backup copy of the source file?", vbYesNo, "Confirm Backup")
If ConfirmBackup = vbNo Then
    MsgBox "Try again when you have a backup copy of the source file", vbOKOnly, "Backup Required"
    Exit Sub
End If

' Find and open the source file
Application.FindFile
Set SourceWorkbook = ActiveWorkbook
SourceWorkbookName = ActiveWorkbook.Name
SourceWorkbookDirectoryPath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(SourceWorkbookName))

' Create a new target workbook in the same folder as the source workbook
Workbooks.Add
ActiveWorkbook.SaveAs _
        Filename:=SourceWorkbookDirectoryPath & "TargetWorkbook.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, ConflictResolution:=True

' Copy each worksheet in SourceWorkbook to TargetWorkbook THIS IS WHERE THE FIX IS NEEDED
For Each SourceWorksheet In SourceWorkbook.Worksheets
    TargetWorkbook.Sheets(SourceWorksheet.Name).Delete
    SourceWorksheet.Copy After:=TargetWorkbook.Sheets(TargetWorkbook.Sheets.Count)
Next

' Close SourceWorkbook, rename SourceWorkbook with suffix "_OLD"
SourceWorkbook.Close SaveChanges:=True
Name SourceWorkbookDirectoryPath & SourceWorkbookName As SourceWorkbookDirectoryPath & SourceWorkbookName & "_OLD"

' Global replace to remove any references to old workbook. (Fixes interbook links.)
Cells.Replace What:="[" & SourceWorkbookName & "]", _
              Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
              False, SearchFormat:=False, ReplaceFormat:=False

' Rename TargetWorkbook as SourceWorkbook's original name, delete TargetWorkbook
ActiveWorkbook.SaveAs _
        Filename:=SourceWorkbookDirectoryPath & SourceWorkbookName, _
        FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=True
Kill SourceWorkbookDirectoryPath & "TargetWorkbook.xlsx"

End Sub

I hope it helps

Answer 2

Use Workbooks("TargetWorkbook.xlsx").Activate instead of Windows...