Question

我有一个代码，列出航空公司的飞行列表并将它们匹配，以便为我提供完整的航班。代码可以工作但是......由于需要经过大量的数据，它需要很长的时间（仅45,000行，45-60分钟）。这是复杂的，整个代码大约需要2个小时才能运行。是否有更快的方法来获得相同的结果？

这是我当前的代码，它真的让整个过程陷入困境：

Sub BuildingLines()
'strings together segments into trip

Dim i As Long
Dim z As Long
Dim T As Long
Dim c As Long
Dim a As Long
Dim f As Long
Dim l As Long
Dim g As Long


Dim y As String
Dim b As String

Set ref = Sheets("Ref")

With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row

For a = 24 To g

    If ref.Cells(a, 2) = "" Then GoTo nexta

    f = ref.Cells(a, 2)
    c = ref.Cells(a, 3)
    l = ref.Cells(a, 4)
    Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))

    For i = f To l

        Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
    DoEvents

    'On Error GoTo NextI

    If IsError(Application.Match(.Cells(i, 2), LegTable, 0)) Then
        GoTo nexti

    Else
            y = Application.Match(.Cells(i, 2), LegTable, 0) + f - 1
            .Cells(i, 1).End(xlToRight).Offset(0, 1).Value2 = .Cells(y, 2)

                Do
                'On Error GoTo NextI
                If IsError(Application.Match(.Cells(y, 2), LegTable, 0)) Then

                GoTo nexti
                Else
                    b = Application.Match(.Cells(y, 2), LegTable, 0) + f - 1
                    h = .Cells(b, 2)
                    .Cells(i, 1).End(xlToRight).Offset(0, 1) = h
                    y = b
                End If
                Loop
nexti:

        End If

    b = ""
    y = ""

    Next i
nexta:
Next a
End With
End Sub

数据是大约50多个字符的所有字符串数据。

感谢您的任何推荐。

Answer 1

非常感谢A.S.H.在你的帮助下，我不仅学到了很多关于使用数组的知识，而且最终还是将我的运行时间从大约90分钟缩短到了超过3分钟。这是我的最终工作代码，它结合了您的建议。

Sub BuildingLines()
'strings together segments into trip

Dim i As Long
Dim z As Long
Dim c As Long
Dim f As Long
Dim l As Long
Dim LegTable As Range
Dim TurnTable As Range
Dim FirstTurn() As Variant
Dim NextTurn() As Variant
Dim y As String
Dim b As String
Dim FTtext As String
Dim wb As Workbook
Dim ref As Worksheet

Set wb = ThisWorkbook
Set ref = wb.Sheets("Ref")

With Sheets("MoveData")
z = .Cells(1, 1).End(xlDown).Row
x = .Cells(2, 1).End(xlToRight).Column
Range(.Cells(1, 3), (.Cells(z, x + 3))).Clear
z = .Cells(1, 1).End(xlDown).Row
g = ref.Cells(24, 1).End(xlDown).Row

For a = 24 To g

    If ref.Cells(a, 2) = "" Then GoTo NextA

    f = ref.Cells(a, 2)
    c = ref.Cells(a, 3)
    l = ref.Cells(a, 4)
    Set LegTable = Range(.Cells(f, 1), .Cells(l, 1))
    Set TurnTable = Range(.Cells(f, 1), .Cells(l, 2))

    FirstTurn = TurnTable


        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=LegTable, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange TurnTable
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    For i = f To l

        Application.StatusBar = "Progress: Step 5 of 20 - Building lines for " & ref.Cells(a, 1) & " (" & (a - 23) & " A/C types of " & (g - 23) & ") : " & (i - f) + 1 & " Legs of " & c & " analyzed. (" & Format(((i - f) + 1) / c, "Percent") & ")"
    DoEvents

    y = 0
    b = 0

        y = Application.Match(.Cells(i, 2), LegTable, 1)
        If .Cells(i, 2) <> FirstTurn(y, 1) Then GoTo NextI

        NextLeg = NextLeg + 1
        ReDim Preserve NextTurn(0, 1 To NextLeg)
        NextTurn(0, NextLeg) = FirstTurn(y, 2)

            Do
                FTtext = FirstTurn(y, 2)
                On Error GoTo errhdlr
                b = Application.WorksheetFunction.Match(FTtext, LegTable, 1)
                If FTtext <> FirstTurn(b, 1) Then GoTo NextI

                NextLeg = NextLeg + 1
                ReDim Preserve NextTurn(0, 1 To NextLeg)
                NextTurn(0, NextLeg) = FirstTurn(b, 2)
                y = b
            Loop

errhdlr:
    Resume NextI
NextI:

    If NextLeg > 0 Then Range(.Cells(i, 3), .Cells(i, NextLeg + 2)).Value = NextTurn
    Erase NextTurn
    NextLeg = 0
    Next i

Set LegTable = Nothing
Set TurnTable = Nothing
Erase NextTurn
Erase FirstTurn

NextA:
Next a
End With

End Sub

我首先尝试仅使用数组，但Match函数在数组中是WAY SLOWER。所以我最终使用Match找到索引，然后从数组中获取数据以构建我的第二个数组，然后成为我的输出。我迫不及待地想让我的新知识与这个项目的其余部分相适应，并将我的运行时间从2小时缩短到几分钟！再次谢谢!!!

更快的匹配代码

1 个答案: