This is the macro that's failing:
Sub save_report()
'1. select five new 'mandatory' (O/G/E/I/R) sheets from report master file
and dump into new WB
' --> uses selname and resname set above to select O and R sheets
'2. dump customer & drill sheets into new WB
'3. add glossary(ies)
'4. save & close new WB
Dim M_S As Object
Set M_S = MATRIX_STATIONS 'sheet used for misc referencing
Dim fn As String
Dim WSn(0, 4) As String
Dim sh As Worksheet
Dim blnReplace As Boolean 'this isn't used now as I process one sheet at a
time
Dim w As Integer
Dim stn As String
Dim WSo As Object
Dim src As String, bkmk As String, txt As String
Set WB = Workbooks("REPORT.xls")
'testing
' Set M_M = MATRIX_MISC 'similar to M_S set above
' selname = "Overview MAN 2009-06"
' BR = "BMAN"
' resname = "MAN Alerts 2009-06"
'--------------------
' MANDATORY SHEETS
'--------------------
'select mandatory (O/G/E/I/A) sheets from scorecard master file and dump
into new WB
WSn(0, 0) = selname
WSn(0, 1) = "General"
WSn(0, 2) = "Export"
WSn(0, 3) = "Import"
WSn(0, 4) = resname
'only works on sheets that exist
If fn_SheetExists(WSn(0, 0)) = False Then
MsgBox "WHOOPS! No overview sheet = error"
GoTo Skip
Else:
With Sheets(selname)
If RptLvl = "R" Then
.Shapes("ShowCustomerDataButton").Delete
.Shapes("GoToAlertsButton").Delete
End If
If RptLvl = "U" Then
.Shapes("GoToAlertsButton").Delete
End If
End With
For w = 1 To 3 'G/E/I
'only if G/E/I sheet exists
If fn_SheetExists(WSn(0, w)) = True Then
'add sheet hyperlinks as appropriate
Set WSo = Sheets(WSn(0, w))
With WSo.Range("A1")
'add Overview link
If fn_SheetExists(WSn(0, 0)) = True Then
With .Offset(0, 12)
src = "A1"
bkmk = "'" & selname & "'!A1"
txt = "Overview"
.Hyperlinks.Add _
Anchor:=.Range(src), _
Address:="", _
SubAddress:=bkmk, _
TextToDisplay:=txt
.Font.Size = 8
End With
Else:
.Offset(0, 12).Value = " "
End If
'add General link
If fn_SheetExists(WSn(0, 1)) = True Then
If Not WSo.Name = "General" Then
With .Offset(0, 13)
src = "A1"
bkmk = "'General'!A7"
txt = "General"
.Hyperlinks.Add _
Anchor:=.Range(src), _
Address:="", _
SubAddress:=bkmk, _
TextToDisplay:=txt
.Font.Size = 8
End With
End If
Else:
.Offset(0, 13).Value = " "
End If
'add Export link
If fn_SheetExists(WSn(0, 2)) = True Then
If Not WSo.Name = "Export" Then
With .Offset(0, 14)
src = "A1"
bkmk = "'Export'!A7"
txt = "Export"
.Hyperlinks.Add _
Anchor:=.Range(src), _
Address:="", _
SubAddress:=bkmk, _
TextToDisplay:=txt
.Font.Size = 8
End With
End If
Else:
.Offset(0, 14).Value = " "
End If
'add Import link
If fn_SheetExists(WSn(0, 3)) = True Then
If Not WSo.Name = "Import" Then
With .Offset(0, 15)
src = "A1"
bkmk = "'Import'!A7"
txt = "Import"
.Hyperlinks.Add _
Anchor:=.Range(src), _
Address:="", _
SubAddress:=bkmk, _
TextToDisplay:=txt
.Font.Size = 8
End With
End If
Else:
.Offset(0, 15).Value = " "
End If
'add Alerts link
If fn_SheetExists(WSn(0, 4)) = True Then
With .Offset(0, 16)
src = "A1"
bkmk = "'" & resname & "'!A1"
txt = "Alerts"
.Hyperlinks.Add _
Anchor:=.Range(src), _
Address:="", _
SubAddress:=bkmk, _
TextToDisplay:=txt
.Font.Size = 8
End With
Else:
.Offset(0, 16).Value = " "
End If
End With
End If
Next w
'select sheets
blnReplace = True 'first sheet replaces selected
For w = 0 To 4
If fn_SheetExists(WSn(0, w)) = True Then Sheets(WSn(0,
w)).Select blnReplace
blnReplace = False 'subsequent sheets add to selected array
Next w
End If
'protect and move/copy to create new WB
ActiveWindow.SelectedSheets.Move
'remember new WB name
fn = ActiveWorkbook.Name
'---------------
' DATA SHEETS
'---------------
If Not RptLvl = "B" Then GoTo SkipData '!! is this required?
WB.Activate
stn = " Data "
'commented, owing to sheet move errors
' blnReplace = True
' For Each sh In WB.Worksheets
' If InStr(1, sh.Name, stn) Then
' sh.Select blnReplace
' blnReplace = False
' End If
' Next sh
'
''move to new WB
' ActiveWindow.SelectedSheets.Copy
After:=Workbooks(fn).Sheets(Workbooks(fn).Sheets.Count)
' WB.Activate
' ActiveWindow.SelectedSheets.Delete
For Each sh In WB.Worksheets
If InStr(1, sh.Name, stn) Then
sh.Copy After:=Workbooks(fn).Sheets(Workbooks(fn).Sheets.Count)
sh.Delete
Else: End If
Next sh
SkipData:
'!!!!!!
'!!!!!!
'macro fails during sheets.move in the next part
'!!!!!!
'!!!!!!
'-------------------
' CUSTOMER SHEETS
'-------------------
If RptLvl = "R" Then GoTo SkipCustomer '!! is this required?
WB.Activate 'source workbook
'move any customer & drill output sheets (all contain the station/region
name or "UK")
stn = "Cust"
For Each sh In WB.Worksheets
If InStr(1, sh.Name, stn) Then sh.move
After:=Workbooks(fn).Sheets(Workbooks(fn).Sheets.Count)
Next sh
SkipCustomer:
'-----------------
' GLOSSARY(IES)
'-----------------
Workbooks(fn).Sheets.Add After:=Sheets(Workbooks(fn).Worksheets.Count)
With ActiveSheet
.Name = "Glossary"
.Tab.ColorIndex = 1
M_M.Range("__Glossary").Copy
.PasteSpecial
.Columns("A:I").EntireColumn.AutoFit
.Columns("A").EntireColumn.Hidden = True
.Columns("C").EntireColumn.Hidden = True
.Columns("F:G").EntireColumn.Hidden = True
showallobjects 'prevents errors in hiding columns and rows
.Range(Range("IV1"), Range("IV1").End(xlToLeft).Offset(0,
1)).EntireColumn.Hidden = True
.Range(Range("A65536"), Range("A65536").End(xlUp).Offset(0,
1)).EntireRow.Hidden = True
.Range("B1").Value = "Description" 'removes the words "max width
245p"
.Range("A1").Select
End With
'-------------------
' SAVE NEW REPORT
'-------------------
'all sheets are now in new workbook "fn"
Workbooks(fn).Activate
With ActiveWorkbook
'add timestamp to overview sheet
.Sheets(selname).Range("TO_datestamp") = "Produced " & Now
'finalise all sheets in new report
Do Until w = .Sheets.Count
With .Sheets(w)
'cancel Build in Progress
If Range("A1") = "BIP" Then Range("A1") = ""
'hide customer data sheets
If InStr(1, .Name, "Cust") Then .Visible = False
'password protect with PW
.Protect Password:=PW, DrawingObjects:=True, Contents:=True,
Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingColumns:=True,
AllowFormattingRows:=True, _
AllowInsertingColumns:=True, AllowInsertingRows:=True,
AllowDeletingColumns:=True, AllowDeletingRows:=True, _
AllowSorting:=True, AllowFiltering:=True,
AllowUsingPivotTables:=True
'set focus on all sheets to A1
'.Range("A1").Select
End With
w = w + 1
Loop
'hide sheet tabs
ActiveWindow.TabRatio = 0
'save new report to (shared drive)
'path has generic format "\\UKOV\RGN\BSTN\"
If RptLvl = "B" Then
'set new fn before save: "STN YYYY-MM" (len 11)
fn = Right(selname, 11) & ".xls"
'set path (testing will save to My Docs, may eventually need to swap for
production lookup from M_R)
Dim path As String
path = M_M.Range("_PATH_reports") _
& WorksheetFunction.Index(M_S.Range("StnRReport"),
WorksheetFunction.Match(BR, M_S.Range("StnBSTN"), 0)) & "\" _
& BR & "\"
ElseIf RptLvl = "R" Then
fn = Right(selname, 12) & ".xls"
path = M_M.Range("_PATH_reports") _
& BR & "\"
ElseIf BR = "UKOV" Then
fn = Right(selname, 12) & ".xls"
path = M_M.Range("_PATH_reports")
End If
.Sheets(1).Select
.SaveAs Filename:=path & fn
.Close
End With
SkipSave:
Skip:
End Sub
