Hello,
When I originally worked up this code, it was running in two minutes or less. The end user called me today and said that it was running really slowly. So I timed it and it was taking longer than twenty minutes, as well as slowing down all of the other applications that I was using on my computer. I have been working on this all day.
My code (in entirety):
Formulas in the workbook (on the two sheets in question):
- The ranges were originally created and are being updated with the UpdateNamedRange Sub.
- This set of formulas was ascertaind with help here: http://www.mrexcel.com/forum/excel-questions/697178-replacement-sumifs.html
- There are only two of the SUMIFS (only because when attempting to use VLOOKUP it erred)
What I've tried:
Application.ScreenUpdating = False
- This didn't save any time, and ended up frustrating me because I was unable to ascertain where in the process the macro was.
Application.Calculation = xlCalculationManual
- This caused an error during the ClearErrs Sub due to the fact that it is looking for the value in the cells.
Determining/Deleting Last Cell/Row
- I've gone through all 8 pages and determined the last cell and deleted where needed, saved, closed and reopened. The last cell/row is now correct.
Editing Formulas
- There did turn out to be a location error in my formulas (which this workbook is formula/macro intensive), but after adjusting them, it still didn't make a difference.
The hang up is worst in the ClearErrs Sub. But even bringing the data in has a long hang-up. Any help/suggestions/thoughts would be great at this point.
Thanks!
-Alex
When I originally worked up this code, it was running in two minutes or less. The end user called me today and said that it was running really slowly. So I timed it and it was taking longer than twenty minutes, as well as slowing down all of the other applications that I was using on my computer. I have been working on this all day.
My code (in entirety):
Code:
Sub DataLoad()
'
' DataLoad Macro
'
'
'I added this portion as a way of timing how long the macro was taking to run
Range("J1").FormulaR1C1 = Now()
Range("J1").NumberFormat = "mm/dd/yyyy hh:mm AM/PM"
'
If ActiveSheet.Name <> "TB" Then
Sheets("TB").Select
Else: End If
Columns("C:G").Select
Selection.ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;N:\Acct\Accounting\Financial\MAIPF\MONTHLY\Data File\TB.DAT", Destination:= _
Range("$C:$G"))
.Name = "TB"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
TBFix
UpdateNamedRanges
Range("A1").Select
'I added this portion as a way of timing how long the macro was taking to run
Range("J2").FormulaR1C1 = Now()
Range("J2").NumberFormat = "mm/dd/yyyy hh:mm AM/PM"
'
MsgBox "The macro has finished running."
End Sub
Sub TBFix()
ResetAll
ClearErrs
ClearReint
End Sub
Sub ResetAll()
'Reset formulas
Range("A3").Select
ActiveCell.FormulaR1C1 = "=VALUE(MID(RC[2],4,6))"
Selection.AutoFill Destination:=Range("A3:A300"), Type:=xlFillDefault
Range("B3").Select
ActiveCell.FormulaR1C1 = "=VALUE(MID(RC[1],4,3))"
Selection.AutoFill Destination:=Range("B3:B300"), Type:=xlFillDefault
End Sub
Sub ClearErrs()
'ClearContents of Cells with remaining #VALUE! errors
R = Sheets("TB").UsedRange.Rows.Count + 1
If Sheets("TB").Range("K1") = "" Then
R = 1
End If
Columns("B:B").Select
Set c = Selection.Find(What:="#VALUE!", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
c.ClearContents
If Not c Is Nothing Then
firstAddress = c.Address
Do
R = R + 1
c.ClearContents
Set c = Cells.FindNext(After:=ActiveCell)
On Error Resume Next
c.ClearContents
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End Sub
Sub ClearReint()
Dim Cell As Range
Dim Rng As Range
Dim RngEnd As Range
Dim Wks As Worksheet
Set Wks = Worksheets("TB")
Set Rng = Wks.Range("B3")
Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
For Each Cell In Rng
Select Case Cell.Value
Case 22, 24, 110, 311, 312
'Do nothing - Keep the row
Case Else
Cell = ""
End Select
Next Cell
On Error Resume Next
End Sub
Sub UpdateNamedRanges()
'Update Named Ranges for formulas on the source page
Dim First, Second, Third As Range
Columns("C:C").Select
Set First = Selection.Find(What:="* GENERAL EXPENSES", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 3)
ThisWorkbook.Worksheets("TB").Range("A3", First).Name = "TBFormulaRange1"
Set First = First.Offset(0, -5)
ThisWorkbook.Worksheets("TB").Range("A3", First).Name = "TBSelectRange1"
Set Second = Selection.Find(What:="** ASSETS:", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 3)
Set First = First.Offset(1, 0)
ThisWorkbook.Worksheets("TB").Range(First, Second).Name = "TBFormulaRange2"
Set Second = Second.Offset(1, -5)
Set Third = Range("F65536").End(xlUp)
ThisWorkbook.Worksheets("TB").Range(Second, Third).Name = "TBFormulaRange3"
Set Third = Third.Offset(0, -5)
ThisWorkbook.Worksheets("TB").Range(Second, Third).Name = "TBSelectRange2"
Fill_Blank_Cells
End Sub
Sub Fill_Blank_Cells()
Range("TBSelectRange1").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[1]C"
Range("TBSelectRange2").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[1]C"
End SubFormulas in the workbook (on the two sheets in question):
Code:
=VLOOKUP(B4,TBFormulaRange1,6)- The ranges were originally created and are being updated with the UpdateNamedRange Sub.
Code:
=INDEX(TB!$F:$F,MATCH(1,INDEX((TB!$A:$A=Source!B5)*(TB!$B:$B=Source!C5),0),0))- This set of formulas was ascertaind with help here: http://www.mrexcel.com/forum/excel-questions/697178-replacement-sumifs.html
Code:
=SUMIFS(TB!$F:$F,TB!$A:$A,Source!R12)- There are only two of the SUMIFS (only because when attempting to use VLOOKUP it erred)
What I've tried:
Application.ScreenUpdating = False
- This didn't save any time, and ended up frustrating me because I was unable to ascertain where in the process the macro was.
Application.Calculation = xlCalculationManual
- This caused an error during the ClearErrs Sub due to the fact that it is looking for the value in the cells.
Determining/Deleting Last Cell/Row
- I've gone through all 8 pages and determined the last cell and deleted where needed, saved, closed and reopened. The last cell/row is now correct.
Editing Formulas
- There did turn out to be a location error in my formulas (which this workbook is formula/macro intensive), but after adjusting them, it still didn't make a difference.
The hang up is worst in the ClearErrs Sub. But even bringing the data in has a long hang-up. Any help/suggestions/thoughts would be great at this point.
Thanks!
-Alex
