VBA - оптимизация кода в функции для более быстрой работы

Question

Код работает очень хорошо, но прежде чем я добавил разделы (13) и (14), он заработал через 6 минут и теперь работает через 16 минут. Если есть способ упорядочить это, чтобы сократить время выполнения, это будет необычно.

Основная часть кода захватывает значения из-под заголовка «CUTTING TOOL» в различных файлах открытия в выделенной папке. Затем они печатаются в книге с кодом, где печатается вся информация, StartSht, и функция изменяет выходную информацию, так что TL - имеет ровно 6 номеров, следующих за ней, а CT - имеет 4 плюс дополнительные 2, если есть «-» после четырех чисел (т. е. CT-0081-01). Если меньше заданной длины, то 0s добавляются сразу после «-». Если значение больше определенной длины, то 0s удаляются сразу после «-».

Любые предложения о том, как потенциально оптимизировать этот код или общие советы, будут отличными. Я попытался реализовать советы по адресу 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 в первой части занимает много времени? Самый простой способ, которым я могу видеть, что вы можете ускорить работу, - это любое время, когда вы выполняете Loop, для каждой ячейки вместо этого устанавливайте переменную, равную этому диапазону, и перебирайте переменную. Это может безумно увеличивать скорость, особенно если ваше прикосновение много клеток. По моему опыту, в основном что-то связанное с клетками - это самая медленная вещь в excel. Я часто конвертирую все в переменные, выполняю всю свою работу, а затем отказываюсь от нее, когда закончу. Я отрезал вещи в течение 2 часов до 2 минут, делая это. Make it faster?

Answer 2

Большая временная заставка перемещала секцию кода, вызываемую двумя функциями из-за переполнения файлов. Таким образом, это не остановится после того, как каждый файл исправит его, но исправьте весь конечный результат в конце. Сократите время выполнения пополам!