Excel VBA Macro - Out of Memory Error - vba

Question

I am having trouble when running a macro whereby I get an error, usually at the end, stating that it "Out of memory".
I've looked over a number of posts and followed recommendations to clear any variables and ensure that the code is "cleaner". However, the error still persists.
I have included the code below, any feedback would be greatly appreciated.
A summary of the purpose:
User clicks a button in a template (which is where the code resides)
Macro 1 cleans up the data that the user pastes into a template page.
A userform will appear after macro 1 which the user must input some data - customer name, contract numbers, etc.
Macro 2 runs when the userform button is submitted which creates a new workbook containing all the data from the template (formatted in macro1) and the data from the form.
It then formats the data for printing with a logo, etc.
Macro 1
Private Sub ContractsClean()
Application.Visible = True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CutCopyMode = False
Sheets("Paste").Name = "Data"
Sheets("Data").Columns("A:B").EntireColumn.Delete
Dim x As Long, lastrow As Long
lastrow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
'Clean the codes
For x = lastrow To 2 Step -1
If Len(Sheets("Data").Cells(x, 1)) > 9 Then
Sheets("Data").Cells(x, 1).Value = Right(Sheets("Data").Cells(x, 1).Value, 9)
End If
Next x
'Add the leading zero
Sheets("Data").Select
Range("A:A").Select
Dim Rng As Range
Dim bChanged As Boolean
Dim icol As Long
Dim sString As String
Dim iWSs As Long
iWSs = Workbooks.Count
If iWSs >= 1 Then
icol = Selection.Column
lastrow = Cells(Rows.Count, icol).End(xlUp).Row
For Each Rng In Selection
If TypeName(Rng.Value) = "Double" Then
If Left(Rng.Value, 1) = "9" Then
Rng = "'0" & Rng.Value
bChanged = True
End If
End If
If TypeName(Rng.Value) = "String" Then
If Left(Rng.Value, 3) = "09-" Then
sString = Rng.Value
sString = "'" & Replace(sString, "-", "")
Rng.Value = sString
bChanged = True
End If
End If
If Rng.Errors(xlNumberAsText).Value = True And bChanged = True Then Rng.Errors(xlNumberAsText).Ignore = True
If Rng.Row = lastrow Then Exit For
Next Rng
End If
If iWSs >= 1 Then
icol = Selection.Column
lastrow = Cells(Rows.Count, icol).End(xlUp).Row
For Each Rng In Selection
If TypeName(Rng.Value) = "Double" Then
If Left(Rng.Value, 1) = "8" Then
Rng = "'0" & Rng.Value
bChanged = True
End If
End If
If TypeName(Rng.Value) = "String" Then
If Left(Rng.Value, 3) = "08-" Then
sString = Rng.Value
sString = "'" & Replace(sString, "-", "")
Rng.Value = sString
bChanged = True
End If
End If
If Rng.Errors(xlNumberAsText).Value = True And bChanged = True Then Rng.Errors(xlNumberAsText).Ignore = True
If Rng.Row = lastrow Then Exit For
Next Rng
End If
Rng = Empty
bChanged = Empty
icol = Empty
sString = Empty
iWSs = Empty
Sheets("Data").Columns("B").EntireColumn.Delete
Sheets("Data").Range("C1").Value = "Quantity"
Sheets("Data").Columns("D").EntireColumn.Delete
Sheets("Data").Columns("E").EntireColumn.Delete
Sheets("Data").Range("E:F").NumberFormat = "dd/mm/yyyy"
Dim ws As Worksheet
Set ws = Sheets("Data")
ws.Range("A:B").Locked = False
ws.Range("C:D").Locked = True
ws.Range("E:F").Locked = False
ws.Protect DrawingObjects:=True, Contents:=True, Scenarios:= _
True, AllowDeletingRows:=True, AllowFormattingCells:=True, AllowFiltering:=True, AllowInsertingRows:=True, Password:="Sanchez7"
'Completion message box
Dim Answer As String
Dim MyNote As String
'Place your text here
MyNote = "Cleanse complete. Do you want to create a local price agreement?"
'Display MessageBox
Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "Action")
If Answer = vbNo Then
'Code for No button Press
Else
'Code for Yes button Press
ProposalForm.Show
End If
Answer = Empty
MyNote = Empty
lastrow = Empty
End Sub
Form Code
Private Sub CommandButton1_Click()
Dim sBuyGroup As String, sLPA As String, sRep As String, sStart As Date, sEnd As Date, sCurrency As String
Dim bExit As Boolean, sSort As String
sBuyGroup = txt_BuyGroup.Text
sLPA = txt_LPA.Text
sRep = txt_Rep.Text
sStart = txt_Start.Text
sEnd = txt_End.Text
sCurrency = ComboBox1.Value
If sBuyGroup = "" Then
bExit = True
MsgBox ("The account number cannot be blank")
End If
If sLPA = "" And bExit = False Then
bExit = True
MsgBox ("The carriage option cannot be blank")
End If
If sRep = "" And bExit = False Then
bExit = True
MsgBox ("The discount option cannot be blank")
End If
If bExit = False Then
Call CreateProposal(sBuyGroup, sLPA, sRep, sStart, sEnd, sCurrency)
Unload Me
Else
End If
sBuyGroup = Empty
sLPA = Empty
sRep = Empty
sStart = Empty
sEnd = Empty
sCurrency = Empty
End Sub
Macro 3 (which I believe is what causes the error)
Sub CreateProposal(sBuyGroup As String, sLPA As String, sRep As String, sStart As Date, sEnd As Date, sCurrency As String)
Dim picLogo As Picture
Set picLogo = Sheets("Info").Pictures("PH_LOGO")
'Copy data from original workbook
Dim exApp As Excel.Application
Set exApp = GetExcelObject()
exApp.Visible = True
Dim OGWB As Workbook
Set OGWB = ActiveWorkbook
OGWB.Sheets("Data").Range("A1:F15000").Copy
Dim wbProposal As Workbook
Set wbProposal = exApp.Workbooks.Add
wbProposal.Activate
wbProposal.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
wbProposal.Sheets("Sheet1").Name = "Raw"
exApp.CutCopyMode = False
exApp.Application.ScreenUpdating = False
'Copy the logo so we can close original workbook
wbProposal.Sheets.Add
wbProposal.Sheets("Sheet2").Name = "LPA"
OGWB.Sheets("Info").Pictures("PH_LOGO").Cut
wbProposal.Sheets("LPA").Paste
Selection.Name = "PH_LOGO"
wbProposal.Sheets("LPA").Pictures("PH_LOGO").Left = 20
wbProposal.Sheets("LPA").Pictures("PH_LOGO").Top = 13
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Width = Application.CentimetersToPoints(5.51)
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Height = Application.CentimetersToPoints(1.64)
wbProposal.Sheets("LPA").Range("A1").Select
Set picLogo = Nothing
exApp.CutCopyMode = False
wbProposal.Activate
wbProposal.Sheets("LPA").Select
'Set BG to all white
With wbProposal.Sheets("LPA").Cells.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Add contact header
wbProposal.Sheets("LPA").Range("D2").Value = "performancehealth.co.uk"
wbProposal.Sheets("LPA").Range("D3").Value = "Main: [phone]"
wbProposal.Sheets("LPA").Range("D4").Value = "Fax: [phone]"
wbProposal.Sheets("LPA").Range("G2").Value = "Nunn Brook Road, Huthwaite,"
wbProposal.Sheets("LPA").Range("G3").Value = "Sutton-in-Ashfield"
wbProposal.Sheets("LPA").Range("G4").Value = "Nottinghamshire, NG17 2HU, UK"
With wbProposal.Sheets("LPA").Range("D2").Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
.Bold = True
End With
With wbProposal.Sheets("LPA").Range("D3:D4,G2:G4").Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0.499984740745262
End With
wbProposal.Sheets("LPA").Range("G6").Value = "Local Price Agreement"
With wbProposal.Sheets("LPA").Range("G6").Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
.Bold = True
.Size = 14
End With
'Arrange Column widths
wbProposal.Sheets("LPA").Columns("A").ColumnWidth = 2.5
wbProposal.Sheets("LPA").Columns("B").ColumnWidth = 13
wbProposal.Sheets("LPA").Range("B14").Value = "Item Code"
wbProposal.Sheets("LPA").Columns("C").ColumnWidth = 41.5
wbProposal.Sheets("LPA").Range("C14").Value = "Item Description"
wbProposal.Sheets("LPA").Columns("D:F").ColumnWidth = 12
wbProposal.Sheets("LPA").Range("D14").Value = "Sale UOM"
wbProposal.Sheets("LPA").Range("E14").Value = "Min Qty"
wbProposal.Sheets("LPA").Range("F14").Value = "Rate"
wbProposal.Sheets("LPA").Columns("G:H").ColumnWidth = 13.5
wbProposal.Sheets("LPA").Range("G14").Value = "Start Date"
wbProposal.Sheets("LPA").Range("H14").Value = "Expiry Date"
wbProposal.Sheets("LPA").Range("B14:H14").Font.Bold = True
With wbProposal.Sheets("LPA").Range("B14:H14").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
'Fill out details from form
wbProposal.Sheets("LPA").Range("B8").Value = "Buying Group:"
wbProposal.Sheets("LPA").Range("B10").Value = "Sales Rep:"
wbProposal.Sheets("LPA").Range("B11").Value = "Currency:"
wbProposal.Sheets("LPA").Range("E8").Value = "LPA Number:"
wbProposal.Sheets("LPA").Range("E10").Value = "Start Date:"
wbProposal.Sheets("LPA").Range("E11").Value = "Expiry Date:"
wbProposal.Sheets("LPA").Range("B8:B11").Font.Bold = True
wbProposal.Sheets("LPA").Range("E8:E11").Font.Bold = True
wbProposal.Sheets("LPA").Range("C8").Value = sBuyGroup
wbProposal.Sheets("LPA").Range("C10").Value = sRep
wbProposal.Sheets("LPA").Range("C11").Value = sCurrency
wbProposal.Sheets("LPA").Range("F8").Value = sLPA
wbProposal.Sheets("LPA").Range("F10").Value = sStart
wbProposal.Sheets("LPA").Range("F11").Value = sEnd
sBuyGroup = Empty
sRep = Empty
sCurrency = Empty
sLPA = Empty
sStart = Empty
sEnd = Empty
'Import the list
Dim lastrow As Long
wbProposal.Sheets("Raw").Select
lastrow = wbProposal.Sheets("Raw").Cells(Rows.Count, "A").End(xlUp).Row
wbProposal.Sheets("Raw").Columns("C").Insert Shift:=xlToRight
wbProposal.Sheets("Raw").Range("F:G").NumberFormat = "dd/mm/yyyy"
wbProposal.Sheets("Raw").Range("E" & lastrow).NumberFormat = "£#,##0.00"
wbProposal.Sheets("Raw").Range("A2:G" & lastrow).Copy
wbProposal.Sheets("LPA").Select
wbProposal.Sheets("LPA").Range("B15").PasteSpecial xlPasteValuesAndNumberFormats
exApp.CutCopyMode = False
'Setup print area
lastrow = wbProposal.Sheets("LPA").Cells(Rows.Count, "B").End(xlUp).Row
wbProposal.Sheets("LPA").Range("F15:F" & lastrow).NumberFormat = "£#,##0.00"
wbProposal.Sheets("LPA").PageSetup.PrintArea = "$A$1:$H$" & lastrow
With wbProposal.Sheets("LPA").PageSetup
.PrintTitleRows = "$14:$14"
.PrintTitleColumns = ""
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
'Redo the picture size (changes during column amendments
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Width = Application.CentimetersToPoints(5.51)
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Height = Application.CentimetersToPoints(1.64)
lastrow = Empty
exApp.DisplayAlerts = False
exApp.CutCopyMode = False
wbProposal.Sheets("LPA").Range("A1").Select
wbProposal.Sheets("Raw").Delete
exApp.DisplayAlerts = False
exApp.ScreenUpdating = True
OGWB.Close False
Set OGWB = Nothing
Set wbProposal = Nothing
Set exApp = Nothing
Application.Quit
End Sub
'-----------------------------------------------------------------------------
' Return an intance of Excel
' First tries to open an existing instance. If it fails, it will create an instance.
' If that fails too, then we return 'Nothing'
'-----------------------------------------------------------------------------
Public Function GetExcelObject() As Object
On Error Resume Next
Dim xlo As Object
' Try to get running instance of Excel
Set xlo = GetObject("Excel.Application")
If xlo Is Nothing Then
Set xlo = CreateObject("Excel.Application")
End If
Set GetExcelObject = xlo
End Function