Улучшение скорости поиска папок в Excel VB

Question

Я работал с макросом электронной таблицы вместе с моим коллегой, чтобы управлять списком действий и управлять связанными папками и файлами.В настоящее время у нас есть рабочий сценарий, однако теперь, когда в списке около 150 элементов, он случайно падает и очень медленно работает.Я очень плохо знаком с программированием и хотел бы улучшить свои навыки, чтобы упростить свою жизнь и упростить управление данными.

В настоящее время макрос выполняет поиск в папке родительского каталога по папке в поисках совпадения.быть причиной зависания.Я пытался заменить его чем-то более эффективным, таким как «Найти» или подобным, но не уверен, что это будет лучше всего из моих исследований.

Буду признателен за любые другие советы, это мой первый макрос, и ему, безусловно, есть чему поучиться.

Sub END_OF_DAY()
Dim oSht As Worksheet
Set oSht = ThisWorkbook.ActiveSheet
Dim aC As Double
Dim colFol As Double
Dim strPath As String
Dim IDPath As String
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fo1
Dim fo2
Dim bFound As Boolean
Dim fMatch As Boolean

strPath = ThisWorkbook.Path
On Error Resume Next

Set fo1 = fso.GetFolder(strPath & "\Items\")



aC = 0
colFol = 1

For aC = 1 To 100
    If oSht.Cells(10, aC).Value = "ID_FOLDER" Then
        colFol = aC
        Exit For
    End If
Next aC

If colFol = 0 Then
    MsgBox "Error: Could not find ID_FOLDER column"
    GoTo endth:
End If

aC = 13
While oSht.Cells(aC, 1).Value <> ""
    IDPath = "ID_" & oSht.Cells(aC, 1).Value
    bFound = False

    For Each fo2 In fo1.subfolders
        fMatch = False
        If Left(fo2.Name, Len(IDPath)) = IDPath Then
            If Len(fo2.Name) = Len(IDPath) Then
                fMatch = True
            ElseIf Asc(Mid(fo2.Name, Len(IDPath) + 1, 1)) < 48 Then
                fMatch = True
            ElseIf Asc(Mid(fo2.Name, Len(IDPath) + 1, 1)) > 57 Then
                fMatch = True
            End If
        End If
        If fMatch = True Then
            If oSht.Cells(aC, colFol).Value = "" Then
                MsgBox "Could not rename folder for ID_" & oSht.Cells(aC,   1).Value & ". Add ID Name to column " & colFol
            Else
                If UCase(fo2.Name) = UCase(oSht.Cells(aC, colFol).Value) Then
                    'do nothing
                Else
                    fo2.Name = oSht.Cells(aC, colFol).Value
                End If
                bFound = True
                Exit For
            End If
        End If

    Next fo2

    If bFound = False Then
        If oSht.Cells(aC, colFol).Value = "" Then
            MsgBox "Could not create folder for ID_" & oSht.Cells(aC, 1).Value & ". Add ID Name to column " & colFol
        Else
            IDPath = strPath & "\Items\" & oSht.Cells(aC, colFol).Value
            fso.CreateFolder IDPath
        End If
    End If

    aC = aC + 1
Wend

strPath = strPath & "\Backup\5A_5B-PER-" & Year(Now()) & Month(Now()) &  Day(Now()) & ".xlsm"
ThisWorkbook.SaveCopyAs strPath


endth:
End Sub