我在运行宏时出现问题，因此我得到一个错误，通常是在最后，说明它是内存不足＆＃34;。 我查看了很多帖子，并按照建议清除任何变量，并确保代码更清晰＆＃34;。但是，错误仍然存在。 我已经包含了下面的代码，我们将非常感谢任何反馈。
目的摘要： 用户单击模板中的按钮（代码所在的位置） 宏1清除用户粘贴到模板页面的数据。 用户表格将出现在宏1之后，用户必须输入一些数据 - 客户名称，合同号等
宏2在提交用户窗体按钮时运行，该按钮创建一个新工作簿，其中包含模板中的所有数据（格式为macro1）和表单中的数据。 然后，它使用徽标等格式化打印数据
宏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
表单代码
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
宏3（我相信是导致错误的原因）
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" & 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