Getting subscript out of range error

[brap1987]

hey guys i am getting this subscript out of range error on my a program in excel set up at my work. The problem is that it was set up a long time ago and it has been converted many times and now it barely works. I fixed most of the errors on it but i am still getting an error on this substring. I am not too good with code so any help would be appreciated. Thanks in advance. ps im not sure how to paste it in its orginal format so bare with me



Sub printacrch()
'Archive data sheets
Application.ScreenUpdating = False
'Start Archeive Process
'Check if folder exists for data
path1 = ThisWorkbook.Sheets(dspa).Cells(59, 3)
dirchk = Dir(path1, 16)
'If not create folder for data
If dirchk = "" Then
MkDir (path1)
Else
End If
'Check if Excel file for er already exits
path2 = ThisWorkbook.Sheets(dspa).Cells(60, 3)
filechk = Dir(path2, 0)
'if file does not exist create if
If filechk = "" Then
Set newbook = Workbooks.Add
With newbook
.SaveAs Filename:=Workbooks("airsheetnew version.xlsm").Sheets(dspa).Cells(60, 3)
End With
'Set rename old summary to 2
Workbooks("airsheetnew version.xlsm").Sheets("Data Input").Cells(8, 37) = 2
Else
'or open the file
Workbooks.Open ThisWorkbook.Sheets(dspa).Cells(60, 3)
'if 1st time through rename old summary sheet
If Workbooks("airsheetnew version.xlsm").Sheets("Data Input").Cells(8, 37) = 1 Then
ActiveWorkbook.Sheets("Summary Sheet Arch").Name = Workbooks("airsheetnew version.xlsm").Sheets("Data Input").Cells(5, 34)
Workbooks("airsheetnew version.xlsm").Sheets("Data Input").Cells(8, 37) = 2
Else
'if not 1st time delete old sheet
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("Summary Sheet Arch").Delete
Application.DisplayAlerts = True
End If
End If

'copy data sheet#1 into file
archxl = Workbooks("airsheetnew version.xlsm").Sheets(dspa).Cells(57, 5)
Workbooks("airsheetnew version.xlsm").Sheets(dspa).Copy Before:=Workbooks(archxl).Sheets(1)
'Error trap for archiving same worksheet numbers
On Error GoTo 987
'rename sheet to test number
Workbooks(archxl).Sheets(1).Name = Workbooks("airsheetnew version.xlsm").Sheets(dspa).Cells(7, 7)
'end error handling
On Error GoTo 0
'Add Delta P to 1st Column in Archive
Workbooks(archxl).Sheets(1).Cells(17, 1) = "Del P"
'Make Delta P Col Visible, centered and 2 decimals
Workbooks(archxl).Sheets(1).Range("a18:a51").Font.ColorIndex = xlAutomatic
Workbooks(archxl).Sheets(1).Range("a18:a51").HorizontalAlignment = xlCenter
Workbooks(archxl).Sheets(1).Range("a18:a51").NumberFormat = "0.00"
'copy summary sheet to archive
'summary sheet
Workbooks("airsheetnew version.xlsm").Sheets("Summary Sheet").Copy Before:=Workbooks(archxl).Sheets(1)
'rename summary sheet
Workbooks(archxl).Sheets(1).DrawingObjects("summary1").Delete
Workbooks(archxl).Sheets(1).DrawingObjects("summary2").Delete
Workbooks(archxl).Sheets(1).Name = "Summary Sheet Arch"
'close archive workbook
ActiveWorkbook.Close (True)
'if data is to be sent ot engineer do it
'Check if to send or not
If ThisWorkbook.Sheets("data input").CheckBoxes("sendeng").Value = xlOn Then
'send to subroutine to send data
If ThisWorkbook.Sheets("Data Input").Cells(28, 26) = 1 Then
GoTo 87
Else
engsenddata
End If
Else
End If
87
'reset archive button
ThisWorkbook.Sheets("data input").DrawingObjects(pa).Font.ColorIndex = 48
ThisWorkbook.Sheets("Data Input").DrawingObjects(pa).Enabled = False
'check if all archive buttons are off then shut off all button
If ActiveSheet.DrawingObjects("pa1").Enabled = False And ActiveSheet.DrawingObjects("pa2").Enabled = False And ActiveSheet.DrawingObjects("pa3").Enabled = False And ActiveSheet.DrawingObjects("pa4").Enabled = False And ActiveSheet.DrawingObjects("pa5").Enabled = False Then
ActiveSheet.DrawingObjects("paall").Font.ColorIndex = 48
ActiveSheet.DrawingObjects("paall").Enabled = False
Else
End If
'activate screen updating
Application.ScreenUpdating = True
'exit subroutine before error handler
Exit Sub
'Rename Error Handling routine
987
'rename sheet to test number + date code for repeat test numbers
Workbooks(archxl).Sheets(1).Name = Workbooks("airsheetnew version.xlsm").Sheets(dspa).Cells(61, 3)
Resume Next
End Sub

 

[baitmaster]

Computers are just dumb tin boxes and follow our every command EXACTLY.

Yours might be. Mine is actually self-aware, and about as co-operative as the wife...

 

[Michael M]

I married her sister.....

 

[brap1987]

i do believe its saying to rename it summary sheet arch

 

[brap1987]

is there a beeter way i could write the code. the only thing i am essential trying to do is create a copy of the entire workbook and save it in a seperate folder with the click of a button

 

[baitmaster]

this code will create a new folder called "archive" next to the current file, then save a copy of itself renamed to include a date & time that ensures uniqueness and auditability

Sub backup()

' create archive folder
Dim strArchive As String: strArchive = ThisWorkbook.Path & "\archive"
On Error Resume Next
    MkDir strArchive
On Error GoTo 0

' get this workbook name details
Dim strThisBook As String: strThisBook = ThisWorkbook.Name
Dim intNameLength As Integer: intNameLength = InStrRev(strThisBook, ".") - 1
Dim intTypeLength As Integer: intTypeLength = Len(strThisBook) - InStrRev(strThisBook, ".") + 1

' save copy with new file name
ThisWorkbook.SaveCopyAs strArchive & "\" & Left(strThisBook, intNameLength) & " backup " & Format(Now, "yyyymmdd hhmmss") & Right(strThisBook, intTypeLength)

End Sub

 

[brap1987]

say i wanted to name it a cells input instead. i would like to keep the date setup but a cells input instead if that makes sense

 

[baitmaster]

of course, you can name it anything you like. I like to keep the same file name because it demonstrates the link back to original source, plus the code is completely transferable across any workbook without having to rely on anything else e.g. a named range

For your request you would change

ThisWorkbook.SaveCopyAs strArchive & "\" & Left(strThisBook, intNameLength) & " backup " & Format(Now, "yyyymmdd hhmmss") & Right(strThisBook, intTypeLength)

to e.g.

ThisWorkbook.SaveCopyAs strArchive & "\" & Sheets("Sheet1").Range("A1").value & " backup " & Format(Now, "yyyymmdd hhmmss") & Right(strThisBook, intTypeLength)