帖子: 17
主題: 4
精華: 0
積分: 22
點名: 0
作業系統: windows10
軟體版本: windows10
閱讀權限: 10
性別: 男
註冊時間: 2020-11-18
最後登錄: 2022-1-12

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 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

新增 Microsoft Excel 工作表.zip (19.53 KB)

樓主熱帖

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

2^#

發表於 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

TOP

quickfixer

中學生 Rank: 2

帖子: 154
主題: 1
精華: 0
積分: 200
點名: 28
作業系統: windwos 7
軟體版本: 64bit
閱讀權限: 20
註冊時間: 2017-5-29
最後登錄: 2024-10-22

3^#

發表於 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

TOP

lilizzzz

小學生 Rank: 1

帖子: 17
主題: 4
精華: 0
積分: 22
點名: 0
作業系統: windows10
軟體版本: windows10
閱讀權限: 10
性別: 男
註冊時間: 2020-11-18
最後登錄: 2022-1-12

4^#

發表於 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

TOP

lilizzzz

小學生 Rank: 1

帖子: 17
主題: 4
精華: 0
積分: 22
點名: 0
作業系統: windows10
軟體版本: windows10
閱讀權限: 10
性別: 男
註冊時間: 2020-11-18
最後登錄: 2022-1-12

5^#

發表於 2020-12-10 08:15 | 只看該作者

回復 3# quickfixer

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

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

TOP

lilizzzz

小學生 Rank: 1

帖子: 17
主題: 4
精華: 0
積分: 22
點名: 0
作業系統: windows10
軟體版本: windows10
閱讀權限: 10
性別: 男
註冊時間: 2020-11-18
最後登錄: 2022-1-12

6^#

發表於 2020-12-10 08:55 | 只看該作者

回復 2# samwang

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

TOP

lilizzzz

小學生 Rank: 1

帖子: 17
主題: 4
精華: 0
積分: 22
點名: 0
作業系統: windows10
軟體版本: windows10
閱讀權限: 10
性別: 男
註冊時間: 2020-11-18
最後登錄: 2022-1-12

7^#

發表於 2020-12-10 09:03 | 只看該作者

回復 3# quickfixer

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

會跳錯

TOP

quickfixer

中學生 Rank: 2

帖子: 154
主題: 1
精華: 0
積分: 200
點名: 28
作業系統: windwos 7
軟體版本: 64bit
閱讀權限: 20
註冊時間: 2017-5-29
最後登錄: 2024-10-22

8^#

發表於 2020-12-10 09:17 | 只看該作者

回復 7# lilizzzz

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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

9^#

發表於 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

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

10^#

發表於 2020-12-10 09:21 | 只看該作者

回復 6# lilizzzz

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

TOP