optimize macro - cutting down loops and autofill

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知 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知 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知 thinking there痴 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

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 Sub

then

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