Copy Sheet To Another Workbook Issue

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
134
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Hi,

I hope someone can tell me where I am wrong with this code.

The purpose of the code is to:
- Check if backup folder is created.
- If its created then it checks if XLSX file (based on number entered by user) is in the folder.
- If it isn't then it will create the workbook.
- If it is then it will open and add a copy of the sheet to the end of the workbook.

I had this working but for some reason it is no longer working when it gets to the below line it spits out a "Run-time Error '9'. Subscript out of range" Error!
I have this in a Module if this makes any difference.

ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Worksheets(Sheets.Count)


VBA Code:
Sub BackUpSheet()
Call SpeedUpOn
' Used to back up sheets
' To use this you must set a reference for Scripting Runtime
' --------------------------------------------------
' 1.  In the VBE window, Choose Tools | References
' 2.   Check the box for Microsoft Scripting Runtime
' --------------------------------------------------

Dim BackupFolderPath As String
Dim BackupFileExists As String
Dim FName As String
Dim FName_Year As String
Dim MonthQ As String

Dim NewBook As Workbook
Dim DestBook As Workbook

Dim fso As FileSystemObject

Set fso = CreateObject("Scripting.FileSystemObject")
   
FName_Year = Application.InputBox("Enter the year the backup relates to (e.g. 2020")
If FName_Year = vbCancel Then
Call SpeedUpOff
Exit Sub
End If

FName = FName_Year & "_.xlsx" 'Year(Now)
BackupFolderPath = "BACKUP FOLDER PATH"
BackupFileExists = BackupFolderPath & "\" & FName

' Checks if BackUp Folder Exists
' If it doesn't then it creates it, if it does then it skips this step.

If fso.FolderExists(BackupFolderPath) = False Then
fso.CreateFolder (BackupFolderPath)
End If        '

' Double checks backup folder exists and also checks if backup file exists.
If fso.FolderExists(BackupFolderPath) Then
If fso.FileExists(BackupFileExists) = False Then

MonthQ = Application.InputBox("Enter Month Number Scheduled e.g. 1 For January", "Enter Month")
If MonthQ = False Then
Exit Sub
End If

Set NewBook = Workbooks.Add

ThisWorkbook.ActiveSheet.Copy After:=NewBook.Sheets(Sheets.Count)

With NewBook
.ActiveSheet.Name = MonthName(MonthQ) & Round(1 + Rnd + 2) 'This adds a random number of 1 + 2 + Random Number to the end of the file name.
.ActiveSheet.Shapes("Group 1").Delete
.ActiveSheet.Shapes("Group 11").Delete
.ActiveSheet.Rows("1:8").Delete
.ActiveSheet.Range("B1").Value = MonthName(MonthQ) & " - " & FName_Year & " Sessions"
.SaveAs Filename:=BackupFolderPath & "\" & FName_Year & "_.xlsx"
.Close
End With

MsgBox "Schedule for " & MonthName(MonthQ) & " has been exported"
Else
   
' File Exists - Opens Workbook and adds a copy to the workbook then saves and closes it.

MonthQ = Application.InputBox("Enter Month Number Scheduled e.g. 1 For January", "Enter Month")
If MonthQ = False Then
Call SpeedUpOff
Exit Sub
Else

Set DestWbk = Workbooks.Open(BackupFileExists)
'Workbooks.Open BackupFileExists
   
ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Worksheets(Sheets.Count)

With DestWbk
With .ActiveSheet
.Name = MonthName(MonthQ) & Round(1 + Rnd + 2) 'This adds a rounded random number of 1 + 2 + Random Number to the end of the file name.
.Shapes("Group 1").Delete
.Shapes("Group 11").Delete
.Rows("1:8").Delete
.Range("B1").Value = MonthQ & " - " & Yearq & " Sessions"
End With
.Save
.Close
End With

MsgBox "Schedule for " & MonthName(MonthQ) & " has been exported"

End If
End If
End If
Call SpeedUpOff
End Sub

Thanks in advance,
t0ny84
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,007
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
What happens with
VBA Code:
ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Worksheets(DestWbk.Sheets.Count)
 

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
134
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
What happens with
VBA Code:
ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Worksheets(DestWbk.Sheets.Count)
Hey Mark it gives a run time Error '9'. Subscript out of range" Error
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,007
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
What does DestWbk show when the error happens?
 

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
134
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web

ADVERTISEMENT

What does DestWbk show when the error happens?
Debug.Print shows the backup workbook name Sessions.xlsx
 

VBasic2008

Board Regular
Joined
Oct 25, 2016
Messages
88
Office Version
  1. 2019
Platform
  1. Windows
You are 'mixing' sheets with worksheets.

If you have a chart in destination workbook, the error will surely occur.
Try the following:

VBA Code:
ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Sheets(DestWbk.Sheets.Count)
 

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
134
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web

ADVERTISEMENT

You are 'mixing' sheets with worksheets.

If you have a chart in destination workbook, the error will surely occur.
Try the following:

VBA Code:
ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Sheets(DestWbk.Sheets.Count)
Hey VBasic2008, this gives an error of Run-Time Error -2147417848 (80010108)
Automation Error
The object invoked has disconnected from its clients.
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,007
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
Do you get the same error with
VBA Code:
Set DestWbk = Nothing
Set DestWbk = Workbooks.Open(BackupFileExists)
'Workbooks.Open BackupFileExists
   
ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Sheets(DestWbk.Sheets.Count)
 

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
134
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Do you get the same error with
VBA Code:
Set DestWbk = Nothing
Set DestWbk = Workbooks.Open(BackupFileExists)
'Workbooks.Open BackupFileExists
 
ThisWorkbook.ActiveSheet.Copy After:=DestWbk.Sheets(DestWbk.Sheets.Count)
Same error unfortunately.

I forgot to mention as well even though it gets the error it still copies the sheet to the end of the workbook.
The other steps after copying don't process after this.
 

t0ny84

Board Regular
Joined
Jul 6, 2020
Messages
134
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Update - the issue is fixed! Steps below how I fixed it in case someone else comes across this issue in the future!

It doesn't look like it was a code issue but an Excel\Workbook issue (don't know exactly).

I recently started noticing when I would try and exit either this workbook or the test backup workbook when the code errored I couldn't I would only get a spinning blue wheel. To exit I would need to use Windows Task Manager.

As the code previously had worked and I couldn't identify anything wrong with it (not that there isn't) I copied the code and pasted it into a blank workbook, the code worked exactly like it should in the new workbook. This led me to believe it was the module\workbook issue rather than code.

Steps:
1) Exported Module
2) Deleted Module
3) Saved Workbook
4) Reopened Workbook
5) Imported Module
6) Ran Code and no issues.
7) Saved Workbook
8) Happy Dance!🕺

Thanks everyone for your help, hopefully doing above has fixed it for the future...

t0ny84
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,128,130
Messages
5,628,871
Members
416,347
Latest member
AT2021

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top