返回列表 上一主題 發帖

[發問] 求救如何縮短VBA執行時間

回復 4# lilizzzz


Sub tt()
Dim xD, Arr, i&, j%, N& '
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([工作表1!U1], [工作表1!A65536].End(3)) '原資料裝入數組
    For i = 1 To UBound(Arr)
        If Not xD.exists(Arr(i, 1)) Then
            N = N + 1   '計算不重複唯一值的次數
            xD(Arr(i, 1)) = N   '不重複唯一值的裝入字典
            For j = 1 To UBound(Arr, 2)   '將唯一值的其它欄位的值裝入數組
                Arr(N, j) = Arr(i, j)
            Next
        End If
    Next
Range("A1").Resize(UBound(Arr), UBound(Arr, 2)) = ""    '清除原資料
Range("A1").Resize(N, UBound(Arr, 2)) = Arr             '貼上唯一值相關的值
End Sub

TOP

回復 7# lilizzzz


你用同一個檔案試的嗎?我用你的檔案測試不會
改成這樣試試
Sheets("工作表1").Range(dr).EntireRow.Delete

TOP

回復 3# quickfixer


  您好,測試時 Range(dr).Delete Shift:=xlUp

會跳錯

TOP

回復 2# samwang


    您好,在測試您的程式碼時發現會有資料沒刪除到的情況

TOP

回復 3# quickfixer


您好,今日會測試您所提供VBA驗證,驗證後會再與您回復,

非常感謝您的耐心解答,謝謝

TOP

回復 2# samwang

您好,您的程式碼可以使用,非常感謝您,另可請教您紅色那幾列的意思嗎 ?

Sub tt()
Dim xD, Arr, i&, j%, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([步驟一!V1], [步驟一!A65536].End(3))
    For i = UBound(Arr) To 1 Step -1
        If Not xD.Exists(Arr(i, 1)) Then
            N = N + 1
            xD(Arr(i, 1)) = N
            For j = UBound(Arr, 1) To 1
                Arr(N, j) = Arr(i, j)

            Next
        End If
    Next
Range("A1").Resize(UBound(Arr), UBound(Arr, 1)) = ""
Range("A1").Resize(N, UBound(Arr, 1)) = Arr

End Sub

TOP

回復 1# lilizzzz

從第一列或最後一列開始都可以
時間0.07=>0.003

    Sub test()

Dim dr As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

Sheets("工作表1").Select
Range("A2").Select

Set dic = CreateObject("scripting.dictionary")
For i = Range("A2000").End(3).Row To 1 Step -1
If dic.exists(Cells(i, "A").Value) Then
dr = dr & i & ":" & i & ","
Else
dic(Cells(i, "A").Value) = ""
End If
Next i

dr = Left(dr, Len(dr) - 1)
Range(dr).Delete Shift:=xlUp

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

End Sub

TOP

回復 1# lilizzzz

請確認是否為您的需求,感謝

Sub tt()
Dim xD, Arr, i&, j%, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([工作表1!U1], [工作表1!A65536].End(3))
    For i = 1 To UBound(Arr)
        If Not xD.Exists(Arr(i, 1)) Then
            N = N + 1
            xD(Arr(i, 1)) = N
            For j = 1 To UBound(Arr, 2)
                Arr(N, j) = Arr(i, j)
            Next
        End If
    Next
Range("A1").Resize(UBound(Arr), UBound(Arr, 2)) = ""
Range("A1").Resize(N, UBound(Arr, 2)) = Arr
End Sub

TOP

        靜思自在 : 要批評別人時,先想想自己是否完美無缺。
返回列表 上一主題