VBA - 优化函数中的代码以加快运行时间

Question

代码运行良好但在我添加第（13）和（14）节之前，它在6分钟内运行，现在在16分钟内运行。如果有一种方法可以简化这一过程以减少运行时间，那将是非同寻常的。

代码的主要部分从标题＆＃39; CUTTING TOOL＆＃39;下面抓取值。在指定文件夹中的各种打开文件中。然后将它们打印到工作簿中，其中包含打印所有信息的代码，StartSht，并且该函数会更改输出信息，以便TL-后面有正好6个数字，CT-有4个，如果有，则加上2个＆＃34; - ＆＃34;在四个数字之后（即CT-0081-01）。如果小于指定的长度，则在＆＃34; - ＆＃34;之后立即添加0。如果大于特定长度，则在＆＃34; - ＆＃34;。

之后立即删除0

有关如何潜在简化此代码或一般提示的任何建议都会很棒。我尝试在this website处实施提示，但没有太大改变。

主要代码：

    With WB
        For Each ws In .Worksheets
'(3)
'find CUTTING TOOL on the source sheet
If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
    Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
    If dict.count > 0 Then
'add the values to the master list, column 3
        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
    Else
        'if no items are under the CUTTING TOOL header
        StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "  "
    End If

    For k = 2 To StartSht.Range("C2").End(xlDown).Row
        ret = ""
        str = StartSht.Range("C" & k).Value

        ret = ExtractNumberWithLeadingZeroes(str, "TL", 6)
        If ret <> "" Then
            StartSht.Range("C" & k).Value = "TL-" & ret
        Else           
            'for CT numbers
            ret = ExtractNumberWithLeadingZeroes(str, "CT", 4)
            If ret <> "" Then
                StartSht.Range("C" & k).Value = "CT-" & ret
            End If

        End If
Next k
...
...
...

功能：

'(8)
'Get the Values from columns with specified headers
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary
    Dim dict As Scripting.Dictionary
    Dim dataRange As Range
    Dim cell As Range
    Dim theValue As String
    Dim splitValues As Variant
    Dim counter As Long
Set dict = New Scripting.Dictionary
Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
' If there are no values in this column then return an empty dictionary
' If there are no values in this column, the dataRange will start at the row
' *above* ch and end at ch
If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then
    GoTo Exit_Function
End If

For Each cell In dataRange.Cells
    counter = counter + 1
    theValue = Trim(cell.Value)
    If Len(theValue) = 0 Then
        theValue = " "
    End If
        'exclude any info after ";"
        If Not IsMissing(vSplit) Then
            splitValues = Split(theValue, ";")
            theValue = splitValues(0)
        End If
        'exclude any info after ","
        If Not IsMissing(vSplit) Then
            splitValues = Split(theValue, ",")
            theValue = splitValues(0)
        End If

        If Not dict.exists(theValue) Then
        dict.Add counter, theValue
        End If
Next cell
Exit_Function:
Set GetValues = dict
 End Function
'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
    Dim rv As Range, c As Range
    For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
        'copy cell value if it contains some string "holder" or "cutting tool"
        If Trim(c.Value) = sHeader Then
        'If InStr(c.Value, sHeader) <> 0 Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function
'(10)
'gets the last row in designated column
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
    End With
End Function
'(11)
'gets the last row in designated sheet
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
    With theWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            ret = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          LookAt:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            ret = 1
        End If
    End With
    GetLastRowInSheet = ret
End Function
'(12)
'get the file name without the extension
Function GetFilenameWithoutExtension(ByVal FileName)
  Dim Result, i
  Result = FileName
  i = InStrRev(FileName, ".")
  If (i > 0) Then
    Result = Mid(FileName, 1, i - 1)
  End If
  GetFilenameWithoutExtension = Result
End Function
'(13)
Public Function ExtractNumberWithLeadingZeroes(ByRef theWholeText As String, ByRef idText As String, ByRef numCharsRequired As Integer) As String
' Finds the first entry of idText, TL/CT, in theWholeText
' Returns the first number found after idText formatted with leading zeroes

Dim returnValue As String
Dim extraValue As String
Dim tmpText As String
Dim firstPosn As Integer
Dim secondPosn As Integer
Dim ctNumberPosn As Integer
    returnValue = ""
    firstPosn = InStr(1, theWholeText, idText)
    If firstPosn > 0 Then
        ' remove any text before first idText, also remove the first idText
        tmpText = Mid(theWholeText, firstPosn + Len(idText))
        'if more than one idText value, delete everything after (and including) the second idText
        secondPosn = InStr(1, tmpText, idText)
        If secondPosn > 0 Then
            tmpText = Mid(tmpText, 1, secondPosn)
        End If
        returnValue = ExtractTheFirstNumericValues(tmpText, 1)
        If idText = "CT" Then
            ctNumberPosn = InStr(1, tmpText, returnValue)
            ' Is the next char a dash? If so, must include more numbers
            If Mid(tmpText, ctNumberPosn + Len(returnValue), 1) = "-" Then
                ' There are some more numbers, after the dash, to extract
                extraValue = ExtractTheFirstNumericValues(tmpText, ctNumberPosn + Len(returnValue))
            End If
        End If
        'force to numCharsRequired numbers if too short; add 0s immediately after idText
        'force to numCharsRequired numbers if too long; eliminate 0s immediately after idText
        ' The CLng gets rid of leading zeroes and the Format$ adds any required up to numCharsRequired chars
        If returnValue <> "" Then
            returnValue = Format$(CLng(returnValue), String(numCharsRequired, "0"))
            If extraValue <> "" Then
                returnValue = returnValue & "-" & extraValue
            End If
        End If
    End If

    ExtractNumberWithLeadingZeroes = returnValue

End Function
'(14)
Private Function ExtractTheFirstNumericValues(ByRef theText As String, ByRef theStartingPosition As Integer) As String

Dim i As Integer
Dim j As Integer
Dim tmpText As String
Dim thisChar As String
    ' Find first number
    For i = theStartingPosition To Len(theText)
        If IsNumeric(Mid(theText, i, 1)) Then
            tmpText = Mid(theText, i)
            Exit For
        End If
    Next i
    ' Find where the numbers end
    For j = 1 To Len(tmpText)
        thisChar = Mid(tmpText, j, 1)
        If Not IsNumeric(thisChar) Then
            tmpText = Mid(tmpText, 1, j - 1)
            Exit For
        End If
    Next j

    ExtractTheFirstNumericValues = tmpText
End Function

Answer 1

你有没有突破点看哪些部分花时间？例如，第一部分的For循环花了很多时间？我可以看到你最简单的方法就是加快速度，任何时候你做一个循环，对于每个单元格而是设置一个等于该范围的变量并循环变量。这可以疯狂地提高速度，特别是如果你触摸很多细胞。根据我的经验，基本上任何与细胞有关的事情都是excel中最慢的事情。我经常将所有内容转换为变量，完成所有工作，然后在完成后将其删除。我这样做了2小时到2分钟。 Make it faster?

Answer 2

节省大量时间的是移动从循环文件外部调用这两个函数的代码部分。这样，它不会在每个文件修复它之后停止，而是在最后修复所有最终输出。将运行时间缩短一半！