title: Excel VBA Macro - Out of Memory Error
body: <p>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.</p>
  
  <p>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.</p>
  
  <p>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.</p>
  
  <p><strong>Macro 1</strong></p>
  
  <pre><code>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)) &gt; 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 &gt;= 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" &amp; 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 = "'" &amp; 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 &gt;= 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" &amp; 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 = "'" &amp; 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
  </code></pre>
  
  <p><strong>Form Code</strong></p>
  
  <pre><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
  </code></pre>
  
  <p><strong>Macro 3 (which I believe is what causes the error)</strong></p>
  
  <pre><code>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: +44 (0) 3448 730 035"
  wbProposal.Sheets("LPA").Range("D4").Value = "Fax: +44 (0) 1623 557 769"
  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" &amp; lastrow).NumberFormat = "£#,##0.00"
  wbProposal.Sheets("Raw").Range("A2:G" &amp; 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" &amp; lastrow).NumberFormat = "£#,##0.00"
  
  wbProposal.Sheets("LPA").PageSetup.PrintArea = "$A$1:$H$" &amp; 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
  </code></pre>