We created this together we can speed it up together!
Originally this was built to run of an email received daily which was about 1000 rows.
Now I’m being asked to back date it so we can store the information to the database.
However 1Months of information 40,00 rows takes 1hr+ to run and even then I’m not sure if worked 100%
i visited http://www.cpearson.com/excel/optimize.htm and took note of some of there methods "FOR EACH Loops" and "Screen Updating" and tried to use them
Is there anything else that jumps out at you guys please???
Or is there something within the code that is unnecessary and could be avoided?
I’m thinking there’s time to be made up in my auto fill method....
Attached is an example on 10,000 rows takes me 10mins running "Transfer" then "Fill": Corporate Action History Master.xlsm
then
Originally this was built to run of an email received daily which was about 1000 rows.
Now I’m being asked to back date it so we can store the information to the database.
However 1Months of information 40,00 rows takes 1hr+ to run and even then I’m not sure if worked 100%
i visited http://www.cpearson.com/excel/optimize.htm and took note of some of there methods "FOR EACH Loops" and "Screen Updating" and tried to use them
Is there anything else that jumps out at you guys please???
Or is there something within the code that is unnecessary and could be avoided?
I’m thinking there’s time to be made up in my auto fill method....
Attached is an example on 10,000 rows takes me 10mins running "Transfer" then "Fill": Corporate Action History Master.xlsm
Code:
Option Explicit
Option Base 0
Public CAHM, CAR As Workbook
Public wsInstructable, wsOutstanding, wsArchive, wsAmendments, wsInstructed As Worksheet
Public i As Long, LastRow As Long
Sub Transfer()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim myAreas As Areas, myArea As Range
Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Set CAHM = Workbooks("Corporate Action History Master.xlsm")
Set ws1 = CAHM.Sheets("Letters - Bulked")
Set wsInstructable = CAHM.Sheets("Todays Instructable Events")
With ws1
With .Range("a2", .Range("a" & Rows.Count).End(xlUp))
.Value = .Value
Set myAreas = .SpecialCells(2).Areas
End With
End With
For Each myArea In myAreas
Union(myArea(1, 1), myArea(1, 2), myArea(1, 3), myArea(1, 7), myArea(1, 9) _
, myArea(1, 10), myArea(1, 22), myArea(1, 24)).Copy _
wsInstructable.Range("a" & Rows.Count).End(xlUp)(2)
Next
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Run ("'Corporate Action History Master.xlsm'!AutoFill.fill")
End SubCode:
Option Explicit
Option Base 0
Public i, c, LastRow As Long
Sub Fill()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
wsInstructable.Activate
Dim rRange As Range
Dim i As Long
Dim rCell As Range
Set rRange = Range("A7", Range("A65536").End(xlUp))
For Each rCell In rRange
Range("K7").Formula = "=Findpaydate(OFFSET('Letters - Bulked'!$AC$1,MATCH(C7,'Letters - Bulked'!C:C,0)-1,0,COUNTIFS('Letters - Bulked'!C:C,C7),1))"
Range("K7").AutoFill Destination:=Range("K7:K" & Cells(Rows.Count, 1).End(xlUp).Row)
Range(Range("K7"), Range("K7").End(xlDown)).Value = Range(Range("K7"), Range("K7").End(xlDown)).Value
Next rCell
For Each rCell In rRange
Range("J7").Formula = "=FindINSTRUCTION(OFFSET('Letters - Bulked'!$AC$1,MATCH(C7,'Letters - Bulked'!C:C,0)-1,0,COUNTIFS('Letters - Bulked'!C:C,C7),1))"
Range("J7").AutoFill Destination:=Range("J7:J" & Cells(Rows.Count, 1).End(xlUp).Row)
Range(Range("J7"), Range("J7").End(xlDown)).Value = Range(Range("J7"), Range("J7").End(xlDown)).Value
Next rCell
For Each rCell In rRange
Range("I7").Formula = "=FindACTIONED(OFFSET('Letters - Bulked'!$AC$1,MATCH(C7,'Letters - Bulked'!C:C,0)-1,0,COUNTIFS('Letters - Bulked'!C:C,C7),1))"
Range("I7").AutoFill Destination:=Range("I7:I" & Cells(Rows.Count, 1).End(xlUp).Row)
Range(Range("I7"), Range("I7").End(xlDown)).Value = Range(Range("I7"), Range("I7").End(xlDown)).Value
Next rCell
For i = Cells(Rows.Count, "A").End(xlUp).Row To 7 Step -1
If Left(Cells(i, "D"), 9) = "AMENDMENT" Then
wsAmendments.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Cells(i, 1).EntireRow.Value
wsAmendments.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).FormatConditions.Delete
Cells(i, 1).EntireRow.ClearContents
Range("A7:P5000").Sort Key1:=Range("C7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
Next i
For i = Cells(Rows.Count, "A").End(xlUp).Row To 7 Step -1
If Cells(i, "D") = "CLIENT INSTRUCTION RECAP" Then
wsArchive.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Cells(i, 1).EntireRow.Value
wsArchive.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).FormatConditions.Delete
Cells(i, 1).EntireRow.ClearContents
Range("A7:P5000").Sort Key1:=Range("C7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
Next i
For i = Cells(Rows.Count, "A").End(xlUp).Row To 7 Step -1
If Cells(i, "D") = "FIRST NOTIFICATION (AUTO)" And Cells(i, "i") = "Yes" And Len(Cells(i, "j") > 6) Then
wsInstructed.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Cells(i, 1).EntireRow.Value
wsInstructed.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).FormatConditions.Delete
Cells(i, 1).EntireRow.ClearContents
Range("A7:P5000").Sort Key1:=Range("C7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
Next i
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Public Function FindPayDate(letterText As Range) As String
Dim letterCell As Range
For Each letterCell In letterText
If InStr(1, letterCell.Value, ":") > 0 Then
Dim variableName As String
variableName = Trim(Left(letterCell.Value, InStr(1, letterCell.Value, ":") - 1))
Select Case variableName
Case "EFFECTIVE DATE"
FindPayDate = (Mid(letterCell.Value, InStr(1, letterCell.Value, ":") + 1, 13))
Case "PAYDATE"
FindPayDate = (Mid(letterCell.Value, InStr(1, letterCell.Value, ":") + 1, 12))
Case "OFFER CLOSES"
FindPayDate = (Mid(letterCell.Value, InStr(1, letterCell.Value, ":") + 1, 12))
Case Else
' DO NOTHING
End Select
End If
Next letterCell
End Function
Public Function FindINSTRUCTION(letterText As Range) As String
Dim letterCell As Range
For Each letterCell In letterText
If InStr(1, letterCell.Value, ":") > 0 Then
Dim variableName As String
variableName = Trim(Left(letterCell.Value, InStr(1, letterCell.Value, ":") - 1))
Select Case variableName
Case "WRITTEN"
FindINSTRUCTION = Trim(letterCell.Value)
Case "STANDING"
FindINSTRUCTION = Trim(letterCell.Value)
Case "DEFAULT"
FindINSTRUCTION = Trim(letterCell.Value)
Case "INSTRUCTION"
FindINSTRUCTION = Trim(letterCell.Value)
Case Else
' DO NOTHING
End Select
End If
Next letterCell
End Function
Public Function FindACTIONED(letterText As Range) As String
Dim letterCell As Range
For Each letterCell In letterText
If InStr(1, letterCell.Value, ":") > 0 Then
Dim variableName As String
variableName = Trim(Left(letterCell.Value, InStr(1, letterCell.Value, ":") - 1))
Select Case variableName
Case "INSTRUCTIONS RECVD"
FindACTIONED = "Yes"
Case "YOUR INSTRUCT REF"
FindACTIONED = "Yes"
Case "INSTRUCTION"
FindACTIONED = "Yes"
Case Else
' DO NOTHING
End Select
End If
Next letterCell
End Function