Hi,
I have a file where I can't amend anything macros in anyway, I always get the 'Out of Memory' message.
However the existing macros run fine. I understand there may be a dodgy loop. I have shared my code below.. any ideas?
Thanks in advance
Len
I have a file where I can't amend anything macros in anyway, I always get the 'Out of Memory' message.
However the existing macros run fine. I understand there may be a dodgy loop. I have shared my code below.. any ideas?
Code:
Sub Num_millions()
'
' Converts all the numbers to millions
'
Application.ScreenUpdating = False
Sheets("|Start Here|").Range("G79") = "m"
On Error Resume Next 'just in case if any sheet is hidden'
For i = 1 To 39
Application.Goto Reference:="Num_" & i
Selection.NumberFormat = "##,##0.0, ;(##,##0.0,); - "
Range("A1").Select
Next i
Application.ScreenUpdating = True
Sheets("ES Cover").Select
MsgBox "The report is now showing numbers in millions"
End Sub
Sub Num_Thousands()
'
' Converts all the numbers to millions
'
Application.ScreenUpdating = False
Sheets("|Start Here|").Range("G79") = "'000"
On Error Resume Next 'just in case if any sheet is hidden'
For i = 1 To 39
Application.Goto Reference:="Num_" & i
'Selection.NumberFormat = "#,##0_);(#,##0)"
Selection.Style = "Comma"
Selection.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
Range("A1").Select
Next i
Application.ScreenUpdating = True
Sheets("ES Cover").Select
MsgBox "The report is now showing numbers in thousands"
End Sub
Sub ReportingPack()
Dim newname As String
Dim ws As Worksheet
Application.ScreenUpdating = False
If Sheets("|Start Here|").Range("D100") = "Customised" Then
MsgBox "This is a previously customised version, please select a new version from T drive." & vbLf & "Exiting Operation"
Exit Sub
End If
MsgBox "Re-directing to save the workbook in your local drive"
newname = Application.GetSaveAsFilename
If newname = "False" Then
MsgBox "You have not saved the file - Exiting Operation"
Exit Sub
End If
ThisWorkbook.SaveAs newname & "xlsm", FileFormat:=52
If Sheets("|Start Here|").Range("C16") = 3 Then '**
Sheets("|Start Here|").Range("D5") = 5004
Else
x = InputBox("Please enter your Region/Company Code" & vbLf & "(Example: 5004, 5245, 5237)")
Sheets("|Start Here|").Range("D5") = x
If x = "" Then
MsgBox "You have not entered region/company number - Exiting operation"
Exit Sub
' insert here the next coditions.
End If
End If
'___________________________________________
' - Tab effect
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
If ws.Range("A1000") = "Summary" Then
Call Prin_Range
ElseIf ws.Range("A1000") = "SGA" Then
Call Prin_Range2
ElseIf ws.Range("A1000") = "MFG" Then
Call Prin_Range3
End If
Next ws
'___________________________________________
y = Sheets("|Start Here|").Range("D5").Value
On Error Resume Next
Z = MsgBox("Reporting Pack is ready for - " & y & ". Do you want to refresh data now?", vbYesNo)
If Z = vbYes Then
'F9 the report
'Application.Run "-607453181" 'F9 the report
Sheets("A.DataMaster").Select
Application.Run "-1015939053" 'F10 the tab
On Error GoTo 0
End If
'----------------------------------------------
'Summary Regions effect
Sheets("Summary Regions").Select
For i = 13 To 153
If Range("a" & i) = 0 Then
Rows(i).Hidden = True
End If
Next i
Range("A1").Select
'-----------------------------------------------
'Productivity Tab effect
If Sheets("Productivity").Visible = True Then
Sheets("Productivity").Select
For i = 5 To 27 Step 2
If Cells(5, i) = 0 Then
Columns(i).Hidden = True
Columns(i + 1).Hidden = True
End If
Next i
Range("A1").Select
End If
'______________________________________________________
'Hide Sheets
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
If ws.Range("A2") = "Hidden" Then
ws.Visible = False
End If
Next ws
Application.ScreenUpdating = True
Sheets("|Start Here|").Range("D100") = "Customised"
Sheets("ES Cover").Select
ActiveWorkbook.Save
MsgBox "Cutomization finished, Figures are in millions, you can change to thousands by clicking the buttons in the 'Start Here' tab"
End Sub
Sub Prin_Range()
'Summary tabs
x = Sheets("|Start Here|").Range("AI4")
c = (x * 3) + 2
ActiveSheet.PageSetup.PrintArea = Range(Cells(3, 2), Cells(75, c)).Address
Application.PrintCommunication = True
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = "$B:$B"
End With
Range(Cells(3, 2), Cells(75, c)).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Range("A1").Select
End Sub
Sub Prin_Range2()
'SGA Tabs
x = Sheets("|Start Here|").Range("AI4")
c = (x * 3) + 2
If x <= 6 Then
Z = 45
Else: Z = 39
End If
ActiveSheet.PageSetup.PrintArea = Range(Cells(4, 2), Cells(71, c)).Address
Application.PrintCommunication = True
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = "$B:$B"
.Zoom = Z
End With
End Sub
Sub Prin_Range3()
'MFG Tabs
x = Sheets("|Start Here|").Range("AI4")
c = (x * 3) + 2
If x <= 6 Then
Z = 45
Else: Z = 40
End If
ActiveSheet.PageSetup.PrintArea = Range(Cells(4, 2), Cells(70, c)).Address
Application.PrintCommunication = True
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = "$B:$B"
.Zoom = Z
End With
End Sub
Sub pstsplvls()
'This macro saves a new file with all the tabs as paste special values, including hidden tabs.
Dim newname As String
Dim wks As Worksheet
Application.ScreenUpdating = False
ThisWorkbook.Save
MsgBox "Please select the location and name of the file"
newname = Application.GetSaveAsFilename
If newname = "False" Then
MsgBox "You have not saved the file - Exiting Operation"
Exit Sub
End If
ThisWorkbook.SaveAs newname & "xlsm", FileFormat:=52
Application.ScreenUpdating = False
Sheets.Add.Name = "Temp2"
' to find the names of the hidden sheets
For Each wks In ActiveWorkbook.Worksheets
If wks.Visible = xlSheetHidden Then
i = i + 1
Worksheets("Temp2").Range("a" & i) = wks.Name
End If
Next wks
'to unhide the hidden sheets
For x = 1 To i
Sheets(Range("a" & x).Value).Visible = True
Next x
'--------------------------------------------------------------------------------------
'This part searches for Cognos links in the tabs and pastes values in those tabs
For Each wks In ThisWorkbook.Worksheets
wks.Select
On Error Resume Next
Cells.Find(What:="=cc.", LookIn:=xlFormulas).Activate
If Err.Number = 0 Then
Application.Run "-1015939053"
Application.ScreenUpdating = False
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
End If
On Error GoTo 0
Next wks
'---------------------------------------------------------------------------------------
'to hide back the sheets
Sheets("Temp2").Select
For x = 1 To i
Sheets(Range("a" & x).Value).Visible = False
Next x
Application.DisplayAlerts = False
Sheets("Temp2").Delete
Application.DisplayAlerts = True
ThisWorkbook.Save
Application.ScreenUpdating = True
MsgBox "Your Report is ready :-)"
End SubThanks in advance
Len
Last edited:
