標題: [發問] 求救如何縮短VBA執行時間 [打印本頁]

---

作者: lilizzzz    時間: 2020-12-9 11:40     標題: 求救如何縮短VBA執行時間

各位先進大家好:

以下是我的附件vba，為範例檔，實務資料列約有1500-2000筆左右雷同資訊

我遇到的問題是，執行這一段vba時，要花費超多時間，

我其他支vba程式點一下就可以跑出來，想請教這組程式碼是哪裡我有寫錯嗎 ? 才會造成執行時間過久，



' 暫停四個容易拖慢的 Excel 功能
' 暫停公式自動計算
' 暫停畫面更新
Application.ScreenUpdating = False
' 暫停狀態列更新
Application.DisplayStatusBar = False
' 暫停事件處理
Application.EnableEvents = False

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

'建立字典，把對象賦予dictionary，(等於判斷依據)
Set dic = CreateObject("scripting.dictionary")
'從A列最後一列開始進行篩選: step -1
'如果是從第一列開始會有刪除跳行情況，無法達成刪除重複效果
For i = Range("A65536").End(3).Row To 1 Step -1
'如果A欄數據已經存在字典中(等於重複了)則執行THEN
If dic.exists(Cells(i, "A").Value) Then
'刪除該列
Rows(i).Delete
Else
'若A欄數據未存於字典內，則將其加入字典
dic(Cells(i, "A").Value) = ""
End If
Next i

' 恢復四個容易拖慢的 Excel 功能
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True

[attach]32774[/attach]

[attach]32774[/attach]

---

作者: samwang    時間: 2020-12-9 16:22

回復 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

---

作者: quickfixer    時間: 2020-12-9 16:59

回復 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

---

作者: lilizzzz    時間: 2020-12-10 08:15

回復 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

---

作者: lilizzzz    時間: 2020-12-10 08:15

回復 3# quickfixer


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

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

---

作者: lilizzzz    時間: 2020-12-10 08:55

回復 2# samwang


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

---

作者: lilizzzz    時間: 2020-12-10 09:03

回復 3# quickfixer


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

會跳錯

---

作者: quickfixer    時間: 2020-12-10 09:17

回復 7# lilizzzz


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

---

作者: samwang    時間: 2020-12-10 09:19

回復 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

---

作者: samwang    時間: 2020-12-10 09:21

回復 6# lilizzzz


    請問可以提供資料嗎? 我再確認問題， 謝謝。

---

作者: quickfixer    時間: 2020-12-10 09:52

本帖最後由 quickfixer 於 2020-12-10 09:54 編輯

回復 7# lilizzzz

猜測可能是資料太多,用字串處理長度太長
改用range集合來刪,請測試

    Sub test()

    Dim dr As Range
    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
            If dr Is Nothing Then
                Set dr = Rows(i)
            Else
                Set dr = Union(dr, Rows(i))
            End If
        Else
            dic(Cells(i, "A").Value) = ""
        End If
    Next i

    dr.EntireRow.Delete
   
    Set dr = Nothing
    Set dic = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True

End Sub

---

作者: lilizzzz    時間: 2020-12-10 16:07

回復 10# samwang


    您好，附檔即是我的資料，只是我實務上再運用的資料筆數從1500-30000都有可能，

不好意思麻煩您了，謝謝，我會用心去吸收這段程式

---

作者: lilizzzz    時間: 2020-12-10 16:09

回復 9# samwang


    請問這一段，
Dim xD, Arr, i&, j%, N& '

為甚麼會用 i&  j% n& ' 來宣告 ?

---

作者: lilizzzz    時間: 2020-12-10 16:10

回復 11# quickfixer


    非常謝謝您，今日下班我再回去測試看看您這段程式碼，

但是有點深奧我需要多花一點時間來吸收qq

---

作者: samwang    時間: 2020-12-10 17:24

回復 13# lilizzzz


    為甚麼會用 i&  j% n& ' 來宣告 ?
-->可參考如下網址解釋，還蠻詳細的，謝謝。
http://forum.twbts.com/viewthrea ... amp;page=1#pid22366
Dim i%就是Dim i As Integer的簡寫
一些常用的代表符號如下
Integer 的型態宣告字元是百分比符號 %
Long 的型態宣告字元為 &
Double 的型態宣告字元是數字符號 #
Single 的型態宣告字元為 !
String 的型態宣告字元為 $

---

作者: lilizzzz    時間: 2020-12-10 22:39

回復 11# quickfixer


    您好，這一份可以執行效率比我的快超多，非常感謝您，我來去吸收這一段，

另想跟您請教，我這裡有一段錄製的巨集，功能是篩選，我在錄製時候搜尋都很快，

可是自己在執行巨集時，搜尋效率要將近一分鐘，請問是我資料檔問題嗎 ?

    Sheets("3P-INSPPROD").Range("A1:AK300000").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("A1:C3"), CopyToRange:=Range("A7:AK7") _
        , Unique:=False

    ActiveWindow.SmallScroll Down:=-27
    Cells.Select

---

作者: lilizzzz    時間: 2020-12-10 22:40

回復 15# samwang


    您好，我有看到這一個說明了，原來是簡寫!非常謝謝您

另想跟您請教，我這裡有一段錄製的巨集，功能是篩選，我在錄製時候搜尋都很快，

可是自己在執行巨集時，搜尋效率要將近一分鐘，請問是我資料檔問題嗎 ?

    Sheets("3P-INSPPROD").Range("A1:AK300000").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("A1:C3"), CopyToRange:=Range("A7:AK7") _
        , Unique:=False

    ActiveWindow.SmallScroll Down:=-27
    Cells.Select

---

作者: n7822123    時間: 2020-12-11 23:04

回復 17# lilizzzz


Range("A1:AK300000")   

範圍太大了，30萬列?，建議先判斷範圍再做篩選，可減少多餘的計算。

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)