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

Excel VB文件夹搜索速度提升

0 个答案: