帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2015-6-19 22:09 | 只看該作者

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

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

去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

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-7-9

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

2^#

發表於 2015-6-19 22:48 | 只看該作者

回復 1# adam2010

試試用Find去找
如下：

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

複製代碼

TOP

lpk187

高中生 Rank: 3 Rank: 3

帖子: 552
主題: 3
精華: 0
積分: 578
點名: 0
作業系統: win7
軟體版本: office 2010
閱讀權限: 50
性別: 男
註冊時間: 2015-2-8
最後登錄: 2024-7-9

2016猴年全勤獎章 2015羊年全勤獎章熱烈參與勳章

3^#

發表於 2015-6-19 23:18 | 只看該作者

回復 1# adam2010

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

TOP

PKKO

　暱稱: PKKO

高中生 Rank: 3 Rank: 3

帖子: 549
主題: 152
精華: 0
積分: 691
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2010
閱讀權限: 50
性別: 男
註冊時間: 2013-8-10
最後登錄: 2022-9-7

論壇榮譽勳章論壇贊助勳章

4^#

發表於 2015-6-20 00:13 | 只看該作者

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

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

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

複製代碼

PKKO

TOP

adam2010

中學生 Rank: 2

帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

5^#

發表於 2015-6-20 06:52 | 只看該作者

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

Adam

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2015-6-20 15:06 | 只看該作者

回復 5# adam2010
可參考一下

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

adam2010

中學生 Rank: 2

帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

7^#

發表於 2015-6-22 07:40 | 只看該作者

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

Adam

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

8^#

發表於 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字典,將回傳值取代原來的陣列值,
'若查不到會回傳空字元取代原來的陣列值
=========================================

執行前:

執行結果:

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

chen301222

中學生 Rank: 2

帖子: 1
主題: 0
精華: 0
積分: 51
點名: 1
作業系統: win10
軟體版本: 2019
閱讀權限: 20
性別: 男
註冊時間: 2023-3-29
最後登錄: 2024-7-20

9^#

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

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

10^#

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP