返回列表 上一主題 發帖

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

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

各位高手,要根據Sheet1的批次
1.jpg
去Sheet2找實際儲位(就是Sheet2的標題列)

目前的巨集如下~可執行,但是資料量大時會找很久,想請教各位是不是有比較快的方法,謝謝!
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)
Adam

回復 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

本帖最後由 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

TOP

回復 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

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

TOP

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

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

執行前:


執行結果:



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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

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

TOP

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

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

TOP

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

由陣列的值放入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
複製代碼
PKKO

TOP

        靜思自在 : 太陽光大、父母恩大、君子量大,小人氣大。
返回列表 上一主題