0

コードのセクションに時間制限を課した経験がある人はいないかと思いました。VBAのExcelスプレッドシートに検索エンジンをプログラムしましたが、重複する結果を削除するコードのセクションがあります。現在、最もあいまいな検索条件が与えられた場合、この部分は非常に長い間続くことがあります。そこで、この操作には時間制限を設けたいと思います。私はどこでも解決策を探してOnTimeを使用してみましたが、必要な方法で機能していないようです。理想的には、時間制限を課し、それがGoToステートメントに達したときに、コード内でさらに先に進めたいと思います。私が読んだことから、OnTimeは操作を中断しませんが、代わりにそれが終了するのを待ちます、これは私が望むものではありません。

助けてくれてありがとう。エイミー

コードを追加しました：

Sub RemoveDuplicates()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Code called upon through the other macros which will remove duplicates from all the   types of search.
Application.StatusBar = "Removing Duplicates...."

Dim k As Integer
Dim SuperArray As String
Dim CheckingArray As String
Dim Duplicate As Boolean
Dim i As Integer
Dim j As Integer
Dim m As Integer
Dim Endrow As Integer
Dim Endcolumn As Integer
Dim w As Integer
Dim x As Integer
Dim n As Integer

w = 1
x = 9

Endcolumn = Module6.Endcolumn(x)
Endrow = Module6.Endrow(w)

If Worksheets("Search Engine").Cells(9, Endrow) = "Percentage Similarity" Then
    Endrow = Endrow - 1
End If

    For i = 9 To Endcolumn

        j = 1
        k = i + 1

        Do While j <> Endrow + 1
            SuperArray = Cells(i, j) & Superstring
            Superstring = SuperArray
            j = j + 1
        Loop

        For k = k To Endcolumn
            m = 1
            Do While m <> Endrow
                CheckingArray = Cells(k, m) & Uberstring
                Uberstring = CheckingArray
                m = m + 1
            Loop
            If Uberstring = Superstring Then
            n = 1
                Do While n <> Endrow + 1
                If Worksheets("Search Engine").Cells(k, n).Interior.ColorIndex = 37 Then
                    Worksheets("Search Engine").Cells(i, n).Interior.ColorIndex = 37
                End If
                n = n + 1
                Loop
                Rows(k).Clear
            End If
            Uberstring = -1
        Next k
        Superstring = -1
    Next i


Do While i > 9
    If Cells(i, 1) = Empty Then
        Rows(i).Delete
    End If
    i = i - 1
Loop

End Sub
4

1 に答える 1

1

For EachコードにWhile ... Wendは、、、などのループが必要だと思いますDo ... Loop Until。

これらの場合、と比較して条件を拡張しますTimer。これにより、0から86400までのDoubleが返され、真夜中から何秒経過したかが示されます。したがって、夜明けも考慮する必要があります。次に、3つの異なるループ構造の実装を示すサンプルコードを示します。

Sub ExampleLoops()
    Dim dblStart As Double
    Dim tmp As Long

    Const cDblMaxTimeInSeconds As Double = 2.5

    dblStart = Timer

    'Example with For loop
    For tmp = 1 To 1000
        tmp = 1     'to fake a very long loop, replace with your code
        DoEvents    'your code here
        If TimerDiff(dblStart, Timer) > cDblMaxTimeInSeconds Then GoTo Finalize 'Alternative: Exit For
    Next

    'Alternative example for Do loop
    Do
        DoEvents 'your code here
    Loop Until TimerDiff(dblStart, Timer) > cDblMaxTimeInSeconds And False 'your condition here

    'Alternative example for While loop
    While TimerDiff(dblStart, Timer) <= cDblMaxTimeInSeconds And True 'your condtion here
        DoEvents 'your code here
    Wend

Finalize:
    'FinalizeCode here
    Exit Sub
End Sub

Function TimerDiff(dblTimerStart As Double, dblTimerEnd As Double)
    Dim dblTemp As Double
    dblTemp = dblTimerEnd - dblTimerStart
    If dblTemp < -43200 Then 'half a day
        dblTemp = dblTemp + 86400
    End If
    TimerDiff = dblTemp
End Function
于 2013-03-26T10:52:43.190 に答える