Board logo

標題: [發問] 是否可加速搜尋的速度 [打印本頁]
作者: adam2010    時間: 2015-6-19 22:09     標題: 是否可加速搜尋的速度

各位高手，要根據Sheet1的批次
[attach]21208[/attach]
去Sheet2找實際儲位(就是Sheet2的標題列)
[attach]21209[/attach]
目前的巨集如下~可執行，但是資料量大時會找很久，想請教各位是不是有比較快的方法，謝謝！
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

[attach]21210[/attach]
作者: lpk187    時間: 2015-6-19 22:48

回復 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    時間: 2015-6-19 23:18

回復 1# adam2010


    承上的程式碼中K1和KK變數只是我觀看變數的變化，和程式無關，可以刪除！
另，工作表1和工作表2亦可改回sheet1和sheet2
作者: PKKO    時間: 2015-6-20 00:13

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

由陣列的值放入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    時間: 2015-6-20 06:52

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

回復 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    時間: 2015-6-22 07:40

感謝GBKEE也出手相助，不過現在才看到，初步測試過OK，下班再研究研究，謝謝！
作者: Andy2483    時間: 2023-5-9 16:09

本帖最後由 Andy2483 於 2023-5-9 16:31 編輯

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

執行前:
[attach]36322[/attach]

執行結果:
[attach]36323[/attach]


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    時間: 2023-11-26 09:39

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    時間: 2023-11-28 08:19

回復 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
作者: shuo1125    時間: 2023-11-28 14:47

本帖最後由 shuo1125 於 2023-11-28 14:49 編輯

回復 10# Andy2483
感謝Andy大分享For Each另解，原來xlCellTypeConstants包含常數的儲存格也能這樣使用，
以下有錯在煩請指正。

        ' 遍歷 xA 中的每一個儲存格，排除標題
    For Each A In xA.Offset(1, 0).SpecialCells(2)
        ' 在字典中添加項目，鍵為A 值為xA
        Z(A.Value) = xA.Cells(1, A.Column).Value
    Next A
作者: Andy2483    時間: 2023-11-28 15:15

回復 11# shuo1125


    謝謝前輩一起學習

       ' ↓遍歷 xA 中的標題下方每一個非空格儲存格，
    For Each A In xA.Offset(1, 0).SpecialCells(2)
        ' ↓在字典中添加項目，Key為A儲存格值 ,Item為A儲存格所在欄位標題列的標題值
        ' ↓A是通用型變數,在此處是物件(儲存格),所以要以A的值納入字典,所以要加.Value或加 & ""
        Z(A.Value) = xA.Cells(1, A.Column).Value
    Next A



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