vba 字典字典有时失败优化

adoration

请老师协助看能不能将sub优化
另我执行字典时，
部分会显示不出来
所以后续参照的资料就不正确了

Sub AAA()
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set Sheet1 = Application.ThisWorkbook.Worksheets("Sheet1")
Set Sheet2 = Application.ThisWorkbook.Worksheets("Sheet2")
Set Sheet3 = Application.ThisWorkbook.Worksheets("Sheet3")
Set Sheet4 = Application.ThisWorkbook.Worksheets("Sheet4")
Set Sheet5 = Application.ThisWorkbook.Worksheets("Sheet5")
Set Sheet6 = Application.ThisWorkbook.Worksheets("Sheet6")
Set Sheet7 = Application.ThisWorkbook.Worksheets("Sheet7")
Set Sheet8 = Application.ThisWorkbook.Worksheets("Sheet8")
Set Sheet9 = Application.ThisWorkbook.Worksheets("Sheet9")
Dim i As Integer

Sheet7.Range("d6:ac100").ClearContents
Sheet9.Range("d6:ah100").ClearContents
Sheet1.Range("O2:U3000").ClearContents
Sheet4.Range("L2:R100").ClearContents
Sheet5.Range("L2:R100").ClearContents


    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheets("Sheet2").Range("a2:j" & Sheets("Sheet2").Range("b65536").End(3).Row).Value
    brr = Sheets("Sheet1").Range("e2:e" & [m65536].End(3).Row)
    ReDim crr(1 To UBound(brr), 1 To 1)
    For i = 1 To UBound(arr)
        d1(arr(i, 1)) = arr(i, 4)
    Next i
    For y = 1 To UBound(brr)
        crr(y, 1) = d1(brr(y, 1))
    Next y
    Sheets("Sheet1").Range("s2").Resize(UBound(crr), 1) = crr

    ReDim crr(1 To UBound(brr), 1 To 1)
    For i = 1 To UBound(arr)
        d1(arr(i, 1)) = arr(i, 3)
    Next i
    For y = 1 To UBound(brr)
        crr(y, 1) = d1(brr(y, 1))
    Next y
    Sheets("Sheet1").Range("t2").Resize(UBound(crr), 1) = crr

    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheets("Sheet2").Range("h2:j" & Sheets("Sheet2").Range("b65536").End(3).Row).Value
    brr = Sheets("Sheet1").Range("f2:f" & [m65536].End(3).Row)
    ReDim crr(1 To UBound(brr), 1 To 1)
    For i = 1 To UBound(arr)
        d1(arr(i, 1)) = arr(i, 3)
    Next i
    For y = 1 To UBound(brr)
        crr(y, 1) = d1(brr(y, 1))
    Next y
    Sheets("Sheet1").Range("U2").Resize(UBound(crr), 1) = crr


For i = 2 To Sheet1.Cells(Rows.Count, "c").End(xlUp).Row

Sheet1.Cells(i, 15) = (Sheet3.Cells(18, 4) - Sheet1.Cells(i, 9)) / 365
Sheet1.Cells(i, 16) = (Sheet3.Cells(18, 4) - Sheet1.Cells(i, 4)) / 365


    If Sheet1.Cells(i, 15) >= 21 Then
    Sheet1.Cells(i, 17) = "21年以上"
         ElseIf Sheet1.Cells(i, 15) >= 16 Then
         Sheet1.Cells(i, 17) = "16-20年"

         ElseIf Sheet1.Cells(i, 15) >= 11 Then
         Sheet1.Cells(i, 17) = "11-15年"

         ElseIf Sheet1.Cells(i, 15) >= 6 Then
         Sheet1.Cells(i, 17) = "6-10年"

         Else
         Sheet1.Cells(i, 17) = "5年以下"

         End If



    If Sheet1.Cells(i, 16) >= 46 Then
    Sheet1.Cells(i, 18) = "46以上"
         ElseIf Sheet1.Cells(i, 16) >= 41 Then
         Sheet1.Cells(i, 18) = "41-45"
         ElseIf Sheet1.Cells(i, 16) >= 36 Then
         Sheet1.Cells(i, 18) = "36-40"
         ElseIf Sheet1.Cells(i, 16) >= 31 Then
         Sheet1.Cells(i, 18) = "31-35"
         ElseIf Sheet1.Cells(i, 16) >= 26 Then
         Sheet1.Cells(i, 18) = "26-30"
         Else
         Sheet1.Cells(i, 18) = "25以下"
         End If

Next

    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheets("Sheet2").Range("o2:p" & Sheets("Sheet2").Range("b65536").End(3).Row).Value
    brr = Sheets("Sheet4").Range("f2:f" & [m65536].End(3).Row)
    ReDim crr(1 To UBound(brr), 1 To 1)
    For i = 1 To UBound(arr)
        d1(arr(i, 1)) = arr(i, 2)
    Next i
    For y = 1 To UBound(brr)
        crr(y, 1) = d1(brr(y, 1))
    Next y
    Sheets("Sheet4").Range("R2").Resize(UBound(crr), 1) = crr

maxRow1 = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To maxRow1
Sheet4.Cells(i, 12) = (Sheet3.Cells(18, 4) - Sheet4.Cells(i, 8)) / 365
Sheet4.Cells(i, 13) = (Sheet3.Cells(18, 4) - Sheet4.Cells(i, 4)) / 365

    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheets("Sheet6").Range("a2:i" & Sheets("Sheet2").Range("b65536").End(3).Row).Value
    brr = Sheets("Sheet5").Range("a2:a" & [m65536].End(3).Row)
    ReDim crr(1 To UBound(brr), 1 To 1)
    For ii = 1 To UBound(arr)
        d1(arr(ii, 1)) = arr(ii, 9)
    Next ii
    For y = 1 To UBound(brr)
        crr(y, 1) = d1(brr(y, 1))
    Next y
    Sheets("Sheet5").Range("R2").Resize(UBound(crr), 1) = crr


    If Sheet4.Cells(i, 12) >= 21 Then
    Sheet4.Cells(i, 14) = "21年以上"
         ElseIf Sheet4.Cells(i, 12) >= 16 Then
         Sheet4.Cells(i, 14) = "16-20年"
         ElseIf Sheet4.Cells(i, 12) >= 11 Then
         Sheet4.Cells(i, 14) = "11-15年"
         ElseIf Sheet4.Cells(i, 12) >= 6 Then
         Sheet4.Cells(i, 14) = "6-10年"
         Else
         Sheet4.Cells(i, 14) = "5年以下"
         End If

    If Sheet4.Cells(i, 13) >= 46 Then
    Sheet4.Cells(i, 15) = "46以上"
         ElseIf Sheet4.Cells(i, 13) >= 41 Then
         Sheet4.Cells(i, 15) = "41-45"
         ElseIf Sheet4.Cells(i, 13) >= 36 Then
         Sheet4.Cells(i, 15) = "36-40"
         ElseIf Sheet4.Cells(i, 13) >= 31 Then
         Sheet4.Cells(i, 15) = "31-35"
         ElseIf Sheet4.Cells(i, 13) >= 26 Then
         Sheet4.Cells(i, 15) = "26-30"
         Else
         Sheet4.Cells(i, 15) = "25以下"
         End If

Next

maxRow2 = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To maxRow2
Sheet5.Cells(i, 12) = (Sheet3.Cells(18, 4) - Sheet5.Cells(i, 8)) / 365
Sheet5.Cells(i, 13) = (Sheet3.Cells(18, 4) - Sheet5.Cells(i, 4)) / 365

    If Sheet5.Cells(i, 12) >= 21 Then
    Sheet5.Cells(i, 14) = "21年以上"
         ElseIf Sheet5.Cells(i, 12) >= 16 Then
         Sheet5.Cells(i, 14) = "16-20年"
         ElseIf Sheet5.Cells(i, 12) >= 11 Then
         Sheet5.Cells(i, 14) = "11-15年"
         ElseIf Sheet5.Cells(i, 12) >= 6 Then
         Sheet5.Cells(i, 14) = "6-10年"
         Else
         Sheet5.Cells(i, 14) = "5年以下"
         End If

    If Sheet5.Cells(i, 13) >= 46 Then
    Sheet5.Cells(i, 15) = "46以上"
         ElseIf Sheet5.Cells(i, 13) >= 41 Then
         Sheet5.Cells(i, 15) = "41-45"
         ElseIf Sheet5.Cells(i, 13) >= 36 Then
         Sheet5.Cells(i, 15) = "36-40"
         ElseIf Sheet5.Cells(i, 13) >= 31 Then
         Sheet5.Cells(i, 15) = "31-35"
         ElseIf Sheet5.Cells(i, 13) >= 26 Then
         Sheet5.Cells(i, 15) = "26-30"
         Else
         Sheet5.Cells(i, 15) = "25以下"
         End If
Next


For i = 6 To Sheet7.Cells(Rows.Count, 3).End(xlUp).Row - 1