[發問] 是否可加速搜尋的速度

adam2010

各位高手，要根據Sheet1的批次

下載 (28.52 KB)

2015-6-19 22:05

去Sheet2找實際儲位(就是Sheet2的標題列)

下載 (40.93 KB)

2015-6-19 22:05

目前的巨集如下~可執行，但是資料量大時會找很久，想請教各位是不是有比較快的方法，謝謝！
Sub AA()
Z = Sheet1.[A65536].End(xlUp).Row
For ZZ = 2 To Z
   For X = 1 To 48
     For Y = 1 To 1000
If Sheet1.Cells(ZZ, 1) = Sheet2.Cells(Y, X) Then
Sheet1.Cells(ZZ, 4) = Sheet2.Cells(1, X)
End If
    Next
      Next
         Next
End Sub

P001-P100電腦.zip (7.8 KB)

下載次數: 15

2015-6-19 22:05

lpk187

回復 1# adam2010


   試試用Find去找
如下：

1. Public Sub test()
   
2. Z = 工作表1.[A65536].End(xlUp).Row
   
3. For Each Rng In Range("a2:a" & Z)
   
4.     Set fng = 工作表2.Cells.Find(Rng, , , , , 2)
   
5.     If Not fng Is Nothing Then
   
6.         K1 = fng.Column
   
7.         kk = 工作表2.Cells(1, fng.Column)
   
8.         工作表1.Cells(Rng.Row, 4) = 工作表2.Cells(1, fng.Column)
   
9.     Else
   
10.         工作表1.Cells(Rng.Row, 4) = "查無此項"
    
11.     End If
    
12. Next
    
13. End Sub

複製代碼

lpk187

回復 1# adam2010


    承上的程式碼中K1和KK變數只是我觀看變數的變化，和程式無關，可以刪除！
另，工作表1和工作表2亦可改回sheet1和sheet2

PKKO

將您的程式碼轉換為陣列
速度就會直接大幅度提升
建立陣列的方式有很多種
下列建立陣列方式需要注意:.每一筆資料都要連續

由陣列的值放入EXCEL的方式也不同
下列方式是最簡單也是最慢的,但您的資料量如果放入值只有在一千個之內
應該還感受不到一秒的差異

1. Sub test()
   
2.     Z = Sheet1.[A65536].End(xlUp).Row
   
3.     Rng = Sheet1.[a1].CurrentRegion
   
4.     rng2 = Sheet2.[a1].CurrentRegion
   
5.    
   
6.     For ZZ = 2 To Z
   
7.         For X = 1 To 48
   
8.             For Y = 1 To 1000
   
9.                 If Rng(ZZ, 1) = rng2(Y, X) Then
   
10.                     Sheet1.Cells(ZZ, 4) = Rng(1, X)
    
11.                 End If
    
12.             Next
    
13.         Next
    
14.     Next
    
15. End Sub

複製代碼

adam2010

感謝lpk187的協助，速度快很多
也謝謝PKKO提供的陣列方式，只是因為來源資料是人員去確認實際儲位逐筆輸入，所以可能無法確定"每一筆資料都要連續"

GBKEE

回復 5# adam2010
可參考一下

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim d As Object, C As Range, i As Double, Ar()
   
4.     Set d = CreateObject("scripting.dictionary") '字典物件
   
5.     For Each C In Sheets("SHEET2").UsedRange.Columns
   
6.         i = 2
   
7.         While C.Cells(i) <> ""
   
8.             d(C.Cells(i).Value) = C.Cells(1)
   
9.             i = i + 1
   
10.         Wend
    
11.     Next
    
12.     With Sheets("SHEET1")
    
13.         Ar = .UsedRange.Columns(1).Value
    
14.         Ar(1, 1) = "實際位置"
    
15.         For i = 2 To UBound(Ar)
    
16.             Ar(i, 1) = d(Ar(i, 1))
    
17.         Next
    
18.         .[D1].Resize(UBound(Ar)) = Ar
    
19.     End With
    
20. End Sub

複製代碼

adam2010

感謝GBKEE也出手相助，不過現在才看到，初步測試過OK，下班再研究研究，謝謝！

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
現學現用 http://forum.twbts.com/redirect. ... o=lastpost#lastpost
Arr(i, 1) = xD(Arr(i, 1))
'↑令以Arr陣列值查xD字典,將回傳值取代原來的陣列值,
'若查不到會回傳空字元取代原來的陣列值
=========================================

執行前:

下載 (98.26 KB)

2023-5-9 16:06

執行結果:

下載 (106.54 KB)

2023-5-9 16:06

Option Explicit
Sub TEST()
Dim Brr, Y, i&, j%, xR As Range, Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2")
Set xR = Sh2.[A1].CurrentRegion: Brr = xR
For i = 1 To UBound(Brr)
   For j = 1 To UBound(Brr, 2)
      If Brr(i, j) <> "" Then Y(Brr(i, j)) = Brr(1, j)
   Next
Next
Set xR = Range(Sh1.[A2], Sh1.Cells(Rows.Count, 1).End(3)): Brr = xR
For i = 1 To UBound(Brr)
   Brr(i, 1) = Y(Brr(i, 1))
Next
xR.Offset(0, 3) = Brr
Set Y = Nothing: Set xR = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing
Erase Brr
End Sub

chen301222

Sub FIND()
Dim arr, i, j, d As Object
Set d = CreateObject("Scripting.Dictionary")
With Sheets("sheet2")
    arr = .[a1].CurrentRegion
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                d(arr(i, j)) = arr(1, j)
            End If
        Next j
    Next i
End With
With Sheets("sheet1")
    arr = .[a1].CurrentRegion
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1)) Then
            arr(i, 4) = d(arr(i, 1))
        End If
    Next i
    .[a1].CurrentRegion = arr
End With
End Sub

Andy2483

回復 9# chen301222


    謝謝論壇,歡迎前輩一起上論壇學習
後學藉此帖練習陣列與字典,學習方案如下

Option Explicit
Sub TEST_1()
Dim Brr, Z, i&, A As Range, j&, xA As Range
Set Z = CreateObject("Scripting.Dictionary")
Set xA = [Sheet2!A1].CurrentRegion
For Each A In xA.Offset(1, 0).SpecialCells(2)
   Z(A & "") = xA.Cells(1, A.Column) & ""
Next
Brr = Range([Sheet1!A2], 工作表1.Cells(Rows.Count, "A").End(3))
For i = 1 To UBound(Brr)
   Brr(i, 1) = Z(Brr(i, 1) & "")
Next
[Sheet1!D2].Resize(UBound(Brr)) = Brr
End Sub