This one really boggles my mind as it works fine on my machine but no-one else can seem to run it. When they do they get a Subscript out of Range 'Error 9' message.
Sub Save()
'On Error GoTo Auto_Error
Application.ScreenUpdating = False
' Defines variable names and types
Dim Sname, Tempname, Wbmaster, WBclient As Variant, i As Integer
Tempname = ActiveWorkbook.Name
i = Len(Tempname) - 4
Wbmaster = Left(Tempname, i)
' Opens dialog box asking the user for the name of the file and the location to save it at
Sname = Application.GetSaveAsFilename(filefilter:="Excel Workbooks (*.xls),*.xls", _
title:="Director's Report - Save Client Copy"
If Sname <> False Then
' Adds new workbook - saves as the name defined by the user
Workbooks.Add
ActiveWorkbook.SaveAs Sname
' Temporarily holds just the name of the new workbook
Tempname = ActiveWorkbook.Name
' Strips out the file extension
i = Len(Tempname) - 4
WBclient = Left(Tempname, i)
' Copies data from the master file to the client file
Workbooks(Wbmaster).Activate
Sheets("Weekly".Select
Cells.Select
Selection.Copy
Workbooks(WBclient).Activate
ActiveWorkbook.Sheets("Sheet1".Range("A1".Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
skipblanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A1".Select
ActiveWindow.Zoom = 90
Workbooks(Wbmaster).Activate
Range("A1".Select
ActiveWorkbook.Sheets("Sec6 Definitions".Activate
Cells.Select
Selection.Copy
Workbooks(WBclient).Activate
Sheets("Sheet2".Select
Range("A1".Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
skipblanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A1".Select
ActiveWindow.Zoom = 75
Workbooks(Wbmaster).Activate
Range("A1".Select
ActiveWorkbook.Sheets("Monthly".Select
Range("A1".Select
Cells.Copy
Workbooks(WBclient).Activate
Sheets("Sheet3".Select
Range("A1".Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
skipblanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A1".Select
ActiveWindow.Zoom = 85
Workbooks(Wbmaster).Activate
Range("A1".Select
' Renames worksheets in the new workbook
Workbooks(WBclient).Activate
Sheets("Sheet1".Name = "Weekly"
Sheets("Sheet2".Name = "Sec6 Definitions"
Sheets("Sheet3".Name = "Monthly"
Sheets("Weekly".Select
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(Wbmaster).Activate
Sheets("Weekly".Select
Range("A1".Select
End If
Application.ScreenUpdating = True
' Exit Sub
'Auto_Error:
' Dim errmsg, style, title, response As String
' errmsg = "File not Saved!"
' style = vbExclamation
' title = "Director 's Report"
' response = MsgBox(errmsg, style, title)
' Exit Sub
End Sub
I've Rem'd out the error trapping routine so I could see what the exact error is. What bother's me most is I con't reproduce the error on my own machine. Weird...
Sub Save()
'On Error GoTo Auto_Error
Application.ScreenUpdating = False
' Defines variable names and types
Dim Sname, Tempname, Wbmaster, WBclient As Variant, i As Integer
Tempname = ActiveWorkbook.Name
i = Len(Tempname) - 4
Wbmaster = Left(Tempname, i)
' Opens dialog box asking the user for the name of the file and the location to save it at
Sname = Application.GetSaveAsFilename(filefilter:="Excel Workbooks (*.xls),*.xls", _
title:="Director's Report - Save Client Copy"
If Sname <> False Then
' Adds new workbook - saves as the name defined by the user
Workbooks.Add
ActiveWorkbook.SaveAs Sname
' Temporarily holds just the name of the new workbook
Tempname = ActiveWorkbook.Name
' Strips out the file extension
i = Len(Tempname) - 4
WBclient = Left(Tempname, i)
' Copies data from the master file to the client file
Workbooks(Wbmaster).Activate
Sheets("Weekly".Select
Cells.Select
Selection.Copy
Workbooks(WBclient).Activate
ActiveWorkbook.Sheets("Sheet1".Range("A1".Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
skipblanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A1".Select
ActiveWindow.Zoom = 90
Workbooks(Wbmaster).Activate
Range("A1".Select
ActiveWorkbook.Sheets("Sec6 Definitions".Activate
Cells.Select
Selection.Copy
Workbooks(WBclient).Activate
Sheets("Sheet2".Select
Range("A1".Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
skipblanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A1".Select
ActiveWindow.Zoom = 75
Workbooks(Wbmaster).Activate
Range("A1".Select
ActiveWorkbook.Sheets("Monthly".Select
Range("A1".Select
Cells.Copy
Workbooks(WBclient).Activate
Sheets("Sheet3".Select
Range("A1".Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
skipblanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A1".Select
ActiveWindow.Zoom = 85
Workbooks(Wbmaster).Activate
Range("A1".Select
' Renames worksheets in the new workbook
Workbooks(WBclient).Activate
Sheets("Sheet1".Name = "Weekly"
Sheets("Sheet2".Name = "Sec6 Definitions"
Sheets("Sheet3".Name = "Monthly"
Sheets("Weekly".Select
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(Wbmaster).Activate
Sheets("Weekly".Select
Range("A1".Select
End If
Application.ScreenUpdating = True
' Exit Sub
'Auto_Error:
' Dim errmsg, style, title, response As String
' errmsg = "File not Saved!"
' style = vbExclamation
' title = "Director 's Report"
' response = MsgBox(errmsg, style, title)
' Exit Sub
End Sub
I've Rem'd out the error trapping routine so I could see what the exact error is. What bother's me most is I con't reproduce the error on my own machine. Weird...