SandsB
Well-known Member
- Joined
- Feb 13, 2007
- Messages
- 734
- Office Version
- 365
- Platform
- Windows
Sometimes after I run a macro on some huge files I have I get an error saying Excel can't continue with the resources available and I need to free up some. After my macro is done, is there something I could do to free up resources? I'm not too tech savvy so I'm thinking a lot of resources are getting held by my macro.
Here's the macro:
-----
Sub ObjFmt()
'
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Columns("C:C").Select
Selection.Cut
Columns("A:A").Select
ActiveSheet.Paste
Columns("C:C").Select
Selection.Delete
Deleting Column Y
Columns("X:X").Select
Selection.Cut
Columns("AX:AX").Select
ActiveSheet.Paste
Columns("X:X").Select
Selection.Delete
Dim WBO As Workbook
Dim WSO As Worksheet
Dim WBN As Workbook
Dim WSN As Worksheet
Dim LastRow As Long
Dim i As Long
Application.ScreenUpdating = False
Set WBO = ActiveWorkbook
Set WSO = WBO.ActiveSheet
Set WBN = Workbooks.Add(template:=xlWBATWorksheet)
Set WSN = WBN.Worksheets(1)
LastRow = WSO.Cells(Rows.Count, "A").End(xlUp).Row
NextRow = 2
For i = 2 To LastRow
If Application.CountIf(WSO.Range(WSO.Cells(2, "A"), WSO.Cells(i, "A")), WSO.Cells(i, "A")) = 1 Then
WSO.Cells(i, "A").Resize(1, 38).Copy Destination:=WSN.Cells(NextRow, "A")
WSO.Cells(i, "AW").Resize(Application.CountIf(WSO.Range(WSO.Cells(2, "A"), WSO.Cells(LastRow, "A")), WSO.Cells(i, "A")), 1).Copy
WSN.Cells(NextRow, "AW").PasteSpecial Transpose:=True
NextRow = NextRow + 1
Application.StatusBar = "This stupid macro is only at record number " & i & " of " & LastRow
End If
Next i
WSN.Columns("X:X").Select
Application.DisplayAlerts = False
Selection.TextToColumns Destination:=Range("X2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="^", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1) _
, Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True
WSN.Range("A1:BF1") = Array("Number", "Queue", "Opened", "Closed Date", "Duration", "State", "ID", "OId", _
"Role", "Type Desc Tx", "Parent", "Child", "Indicator", "Ie", _
"Ie Nb", "EndId", "EndName", "Rept", "Root", "Sub", _
"Resol", "Resol_R", "Resol A", "Device", "R", _
"Prob1", "ProbD", "ResT", "ResD", _
"NoA", "D", "PA", "Out", "Need", "ET", "Flag1", "Flag2", "Flag3", "Blank1", "Blank2", "Blank3", "Blank4", _
"Blank5", "Blank6", "Blank7", "Blank8", "Blank9", "Blank10", "Log 1", "Log 2", "Log 3", "Log 4", "Log 5", "Log 6", "Log 7", "Log 8", "Log 9", "Log 10")
WSN.Columns("Y:BF").Font.Size = 10
WSN.Range("A1:BF1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = 2
.Color = 6299648
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 24
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
WSN.Cells.Select
WSN.Range("L1").Activate
WSN.Cells.EntireColumn.AutoFit
Dim MyFile1 As String
Dim strWBName As String
MyFile1 = InputBox("Enter the date of your input file (MM-DD-YY) or MMM-YY")
strWBName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
ActiveWorkbook.SaveAs Filename:="\\server\folder\" & _
strWBName & Chr(32) & MyFile1 & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
Here's the macro:
-----
Sub ObjFmt()
'
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Columns("C:C").Select
Selection.Cut
Columns("A:A").Select
ActiveSheet.Paste
Columns("C:C").Select
Selection.Delete
Deleting Column Y
Columns("X:X").Select
Selection.Cut
Columns("AX:AX").Select
ActiveSheet.Paste
Columns("X:X").Select
Selection.Delete
Dim WBO As Workbook
Dim WSO As Worksheet
Dim WBN As Workbook
Dim WSN As Worksheet
Dim LastRow As Long
Dim i As Long
Application.ScreenUpdating = False
Set WBO = ActiveWorkbook
Set WSO = WBO.ActiveSheet
Set WBN = Workbooks.Add(template:=xlWBATWorksheet)
Set WSN = WBN.Worksheets(1)
LastRow = WSO.Cells(Rows.Count, "A").End(xlUp).Row
NextRow = 2
For i = 2 To LastRow
If Application.CountIf(WSO.Range(WSO.Cells(2, "A"), WSO.Cells(i, "A")), WSO.Cells(i, "A")) = 1 Then
WSO.Cells(i, "A").Resize(1, 38).Copy Destination:=WSN.Cells(NextRow, "A")
WSO.Cells(i, "AW").Resize(Application.CountIf(WSO.Range(WSO.Cells(2, "A"), WSO.Cells(LastRow, "A")), WSO.Cells(i, "A")), 1).Copy
WSN.Cells(NextRow, "AW").PasteSpecial Transpose:=True
NextRow = NextRow + 1
Application.StatusBar = "This stupid macro is only at record number " & i & " of " & LastRow
End If
Next i
WSN.Columns("X:X").Select
Application.DisplayAlerts = False
Selection.TextToColumns Destination:=Range("X2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="^", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1) _
, Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True
WSN.Range("A1:BF1") = Array("Number", "Queue", "Opened", "Closed Date", "Duration", "State", "ID", "OId", _
"Role", "Type Desc Tx", "Parent", "Child", "Indicator", "Ie", _
"Ie Nb", "EndId", "EndName", "Rept", "Root", "Sub", _
"Resol", "Resol_R", "Resol A", "Device", "R", _
"Prob1", "ProbD", "ResT", "ResD", _
"NoA", "D", "PA", "Out", "Need", "ET", "Flag1", "Flag2", "Flag3", "Blank1", "Blank2", "Blank3", "Blank4", _
"Blank5", "Blank6", "Blank7", "Blank8", "Blank9", "Blank10", "Log 1", "Log 2", "Log 3", "Log 4", "Log 5", "Log 6", "Log 7", "Log 8", "Log 9", "Log 10")
WSN.Columns("Y:BF").Font.Size = 10
WSN.Range("A1:BF1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = 2
.Color = 6299648
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 24
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
WSN.Cells.Select
WSN.Range("L1").Activate
WSN.Cells.EntireColumn.AutoFit
Dim MyFile1 As String
Dim strWBName As String
MyFile1 = InputBox("Enter the date of your input file (MM-DD-YY) or MMM-YY")
strWBName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
ActiveWorkbook.SaveAs Filename:="\\server\folder\" & _
strWBName & Chr(32) & MyFile1 & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub