麻辣家族討論版版 » Excel程式區 » 是否可加速搜尋的速度

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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=78867&ptid=14345]1#[/url] [i]adam2010[/i] [/b]


   試試用Find去找
如下：[code]Public Sub test()
Z = 工作表1.[A65536].End(xlUp).Row
For Each Rng In Range("a2:a" & Z)
    Set fng = 工作表2.Cells.Find(Rng, , , , , 2)
    If Not fng Is Nothing Then
        K1 = fng.Column
        kk = 工作表2.Cells(1, fng.Column)
        工作表1.Cells(Rng.Row, 4) = 工作表2.Cells(1, fng.Column)
    Else
        工作表1.Cells(Rng.Row, 4) = "查無此項"
    End If
Next
End Sub
[/code]

lpk187 發表於 2015-6-19 23:18

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=78867&ptid=14345]1#[/url] [i]adam2010[/i] [/b]


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

PKKO 發表於 2015-6-20 00:13

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

由陣列的值放入EXCEL的方式也不同
下列方式是最簡單也是最慢的,但您的資料量如果放入值只有在一千個之內
應該還感受不到一秒的差異[code]Sub test()
    Z = Sheet1.[A65536].End(xlUp).Row
    Rng = Sheet1.[a1].CurrentRegion
    rng2 = Sheet2.[a1].CurrentRegion
   
    For ZZ = 2 To Z
        For X = 1 To 48
            For Y = 1 To 1000
                If Rng(ZZ, 1) = rng2(Y, X) Then
                    Sheet1.Cells(ZZ, 4) = Rng(1, X)
                End If
            Next
        Next
    Next
End Sub[/code]

adam2010 發表於 2015-6-20 06:52

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

GBKEE 發表於 2015-6-20 15:06

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=78877&ptid=14345]5#[/url] [i]adam2010[/i] [/b]
可參考一下[code]Option Explicit
Sub Ex()
    Dim d As Object, C As Range, i As Double, Ar()
    Set d = CreateObject("scripting.dictionary") '字典物件
    For Each C In Sheets("SHEET2").UsedRange.Columns
        i = 2
        While C.Cells(i) <> ""
            d(C.Cells(i).Value) = C.Cells(1)
            i = i + 1
        Wend
    Next
    With Sheets("SHEET1")
        Ar = .UsedRange.Columns(1).Value
        Ar(1, 1) = "實際位置"
        For i = 2 To UBound(Ar)
            Ar(i, 1) = d(Ar(i, 1))
        Next
        .[D1].Resize(UBound(Ar)) = Ar
    End With
End Sub
[/code]

adam2010 發表於 2015-6-22 07:40

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

Andy2483 發表於 2023-5-9 16:09

[i=s] 本帖最後由 Andy2483 於 2023-5-9 16:31 編輯 [/i]

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
現學現用 [url]http://forum.twbts.com/redirect.php?tid=15008&goto=lastpost#lastpost[/url]
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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=122200&ptid=14345]9#[/url] [i]chen301222[/i] [/b]


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

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

[i=s] 本帖最後由 shuo1125 於 2023-11-28 14:49 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=122205&ptid=14345]10#[/url] [i]Andy2483[/i] [/b]
感謝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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=122210&ptid=14345]11#[/url] [i]shuo1125[/i] [/b]


    謝謝前輩一起學習

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

查看完整版本: 是否可加速搜尋的速度