麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何用VBA找尋數千條記錄？ [打印本頁]

作者: maiko 時間: 2023-4-18 22:20 標題: 如何用VBA找尋數千條記錄？

[attach]36182[/attach]

[attach]36183[/attach]

[attach]36184[/attach]

感激各位賜教！

作者: Andy2483 時間: 2023-4-19 11:01

回復 1# maiko

謝謝前輩發表此主題與範例,謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考

執行提示1:
[attach]36185[/attach]

執行提示2:
[attach]36186[/attach]

Option Explicit
Sub TEST()
Dim Brr, Crr, Y, TT, Er&, R&, C&, i&, Vb&, Ve&, Ter$, Tc$, Td$, Ta$
Dim xR1 As Range, xR2 As Range, Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2")
Set xR1 = Range(Sh1.[E1], Sh1.Cells(Rows.Count, "A").End(xlUp)): Brr = xR1
Sh2.UsedRange.Offset(2, 2).ClearContents
Set xR2 = Range(Sh2.[A1], Sh2.Cells(2, Columns.Count).End(xlToLeft)).EntireColumn
Set xR2 = Intersect(Sh2.UsedRange, xR2): Crr = xR2
For C = 3 To UBound(Crr, 2)
Tc = Crr(2, C)
For R = 3 To UBound(Crr)
   Td = Crr(R, 1): Ta = Crr(R, 2): If Td = "" Or Ta = "" Then GoTo i00
   TT = Td & "|" & Ta & "|" & Tc
   If Y(TT) <> "" Then MsgBox TT & " 項目重複!": Exit Sub
   Y(TT & "|c") = C: Y(TT & "|r") = R: Y(TT) = "@"
i00: Next
Next
For i = 2 To UBound(Brr)
Ta = Brr(i, 1): Tc = Brr(i, 3): Td = Brr(i, 4)
Vb = Val(Brr(i, 2)): Ve = Val(Brr(i, 5))
If Td = "" Or Ta = "" Or Td = "" Then GoTo i01
TT = Td & "|" & Ta & "|" & Tc
If Y(TT) = "" Then Er = Er + 1: Y(TT) = "Err": Ter = Ter & vbLf & TT: GoTo i01
R = Y(TT & "|r"): C = Y(TT & "|c")
If Ve > Val(Y(TT)) Then: Y(TT) = Ve & "^0*" & Vb: Crr(R, C) = Evaluate(Y(TT))
i01: Next
xR2 = Crr: If Er > 0 Then MsgBox Er & " 個組合沒有資料!" & Ter: Er = 0: Ter = ""
For Each TT In Y.KEYS
If Y(TT) = "@" Then Er = Er + 1: Ter = Ter & vbLf & TT
Next
If Er > 0 Then MsgBox Er & " 個組合資料庫找不到!"
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Set xR1 = Nothing
Set xR2 = Nothing: Erase Brr, Crr
End Sub

作者: Andy2483 時間: 2023-4-19 16:40

謝謝論壇,謝謝各位前輩
後學一開始沒看清楚題意,做了個組合的統計,學習的方案也放上來,請各位前輩指教

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

Option Explicit
Sub TEST()
Dim Brr, Crr, TT, Y, Er&, R&, C&, i&, Ter$, Tc$, Td$, Ta$, Vb&
Dim xR1 As Range, xR2 As Range, Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2")
Set xR1 = Range(Sh1.[E1], Sh1.Cells(Rows.Count, "A").End(xlUp)): Brr = xR1
Sh2.UsedRange.Offset(2, 2).ClearContents
Set xR2 = Range(Sh2.[A1], Sh2.Cells(2, Columns.Count).End(xlToLeft)).EntireColumn
Set xR2 = Intersect(Sh2.UsedRange, xR2): Crr = xR2
For C = 3 To UBound(Crr, 2)
Tc = Crr(2, C)
For R = 3 To UBound(Crr)
   Td = Crr(R, 1): Ta = Crr(R, 2): If Td = "" Or Ta = "" Then GoTo i00
   TT = Td & "|" & Ta & "|" & Tc
   If Y(TT) <> "" Then MsgBox TT & " 項目重複!": Exit Sub
   Y(TT & "|c") = C: Y(TT & "|r") = R: Y(TT) = "@"
i00: Next
Next
For i = 2 To UBound(Brr)
Ta = Brr(i, 1): Tc = Brr(i, 3): Td = Brr(i, 4): Vb = Val(Brr(i, 2))
If Td = "" Or Ta = "" Or Td = "" Then GoTo i01
TT = Td & "|" & Ta & "|" & Tc
If Y(TT) = "" Then Er = Er + 1: Y(TT) = "Err": Ter = Ter & vbLf & TT: GoTo i01
R = Y(TT & "|r"): C = Y(TT & "|c"): Crr(R, C) = Crr(R, C) + Vb: Y(TT) = 0
i01: Next
xR2 = Crr: If Er > 0 Then MsgBox Er & " 個組合沒有被統計!" & Ter: Er = 0: Ter = ""
For Each TT In Y.KEYS
If Y(TT) = "@" Then Er = Er + 1: Ter = Ter & vbLf & TT
Next
If Er > 0 Then MsgBox Er & " 個組合資料庫找不到!"
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Set xR1 = Nothing
Set xR2 = Nothing: Erase Brr, Crr
End Sub

作者: Andy2483 時間: 2023-4-20 10:03

謝謝論壇,謝謝各位前輩
後學藉此帖練習與#2樓程序顛倒的方式,學習方案如下,請各位前輩指教

Option Explicit
Sub TEST_1()
Dim Brr, Crr, Y, TT, Er&, R&, C&, i&, Vb&, Ve&, Ter$, Tc$, Td$, Ta$
Dim xR1 As Range, xR2 As Range, Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2")
Set xR1 = Range(Sh1.[E1], Sh1.Cells(Rows.Count, "A").End(xlUp)): Brr = xR1
Sh2.UsedRange.Offset(2, 2).ClearContents
Set xR2 = Range(Sh2.[A1], Sh2.Cells(2, Columns.Count).End(xlToLeft)).EntireColumn
Set xR2 = Intersect(Sh2.UsedRange, xR2): Crr = xR2
For i = 2 To UBound(Brr)
Ta = Brr(i, 1): Tc = Brr(i, 3): Td = Brr(i, 4)
Vb = Val(Brr(i, 2)): Ve = Val(Brr(i, 5))
If Td = "" Or Ta = "" Or Td = "" Then GoTo i01
TT = Td & "|" & Ta & "|" & Tc
R = Y(TT & "|r"): C = Y(TT & "|c")
If Ve > Val(Y(TT)) Then: Y(TT) = Ve & "^0*" & Vb
i01: Next
For C = 3 To UBound(Crr, 2)
Tc = Crr(2, C)
For R = 3 To UBound(Crr)
   Td = Crr(R, 1): Ta = Crr(R, 2): If Td = "" Or Ta = "" Then GoTo i00
   TT = Td & "|" & Ta & "|" & Tc
   If InStr(Y(TT), "^") Then Crr(R, C) = Evaluate(Y(TT))
i00: Next
Next
xR2 = Crr
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Set xR1 = Nothing
Set xR2 = Nothing: Erase Brr, Crr
End Sub

作者: Andy2483 時間: 2023-4-20 13:17

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

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

Option Explicit
Sub TEST_2()
Dim Brr, Crr, Y, TT, R&, C&, R1&, C1&, i&, Vb&, Ve&, Tc$, Td$, Ta$
Dim xR1 As Range, Sh1 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1")
Set xR1 = Range(Sh1.[E1], Sh1.Cells(Rows.Count, "A").End(xlUp)): Brr = xR1
For i = 2 To UBound(Brr)
Ta = Brr(i, 1): Tc = Brr(i, 3): Td = Brr(i, 4)
Vb = Val(Brr(i, 2)): Ve = Val(Brr(i, 5))
If Td = "" Or Ta = "" Or Td = "" Then GoTo i01
TT = Td & "|" & Ta & "|" & Tc
If Y(Td & "|" & Ta) = "" Then
   R = R + 1: R1 = R: Y(Td & "|" & Ta) = R1
   Else
      R1 = Y(Td & "|" & Ta)
End If
If Y(Tc) = "" Then
   C = C + 1: C1 = C: Y(Tc) = C1
   Else
      C1 = Y(Tc)
End If
Y(TT & "|r") = R1: Y(TT & "|c") = C1
If Ve > Val(Y(TT)) Then: Y(TT) = Ve & "^0*" & Vb
i01: Next
ReDim Crr(1 To Y.Count, 1 To Columns.Count)
For Each TT In Y.keys
If InStr(Y(TT), "^") Then
   Crr(Y(TT & "|r") + 2, Y(TT & "|c") + 2) = Evaluate(Y(TT))
   ElseIf TT Like "*|*|*" = False And TT Like "*|*" Then
      Crr(Y(TT) + 2, 1) = Split(TT, "|")(0)
      Crr(Y(TT) + 2, 2) = Split(TT, "|")(1)
   ElseIf InStr(TT, "|") = 0 Then
      Crr(2, Y(TT) + 2) = TT
End If
i00: Next
Crr(1, 1) = "Group2": Crr(1, 2) = "LocnID": Crr(1, 3) = "TenderID"
Workbooks.Add
[A1].Resize(R + 2, C + 2) = Crr
[A1].Item(1, 3).Resize(1, C).Merge
[A1].Item(1, 3).HorizontalAlignment = xlCenter
Set Y = Nothing: Set Sh1 = Nothing: Set xR1 = Nothing: Erase Brr, Crr
End Sub

作者: Andy2483 時間: 2023-4-21 09:20

回復 5# Andy2483

謝謝論壇,謝謝各位前輩
回復自己昨天的不求甚解,不用Split()分割key後代入標題欄,直接以字典item帶入標題欄
請各位前輩指教

Option Explicit
Sub TEST_3()
Dim Brr, Crr, Y, TT, R&, C&, R1&, C1&, i&, Vb&, Ve&, Tc$, Td$, Ta$
Dim xR1 As Range, Sh1 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1")
Set xR1 = Range(Sh1.[E1], Sh1.Cells(Rows.Count, "A").End(xlUp)): Brr = xR1
For i = 2 To UBound(Brr)
Ta = Brr(i, 1): Tc = Brr(i, 3): Td = Brr(i, 4)
Vb = Val(Brr(i, 2)): Ve = Val(Brr(i, 5))
If Td = "" Or Ta = "" Or Td = "" Then GoTo i01
TT = Td & "|" & Ta & "|" & Tc
If Y(Td & "|" & Ta) = "" Then
   R = R + 1: R1 = R: Y(Td & "|" & Ta) = R1
   Y(Td & "|" & Ta & "|1") = Td: Y(Td & "|" & Ta & "|2") = Ta
   Else
      R1 = Y(Td & "|" & Ta)
End If
If Y(Tc) = "" Then
   C = C + 1: C1 = C: Y(Tc) = C1
   Else
      C1 = Y(Tc)
End If
Y(TT & "|r") = R1: Y(TT & "|c") = C1
If Ve > Val(Y(TT)) Then: Y(TT) = Ve & "^0*" & Vb
i01: Next
ReDim Crr(1 To Y.Count, 1 To Columns.Count)
For Each TT In Y.keys
If InStr(Y(TT), "^") Then
   Crr(Y(TT & "|r") + 2, Y(TT & "|c") + 2) = Evaluate(Y(TT))
   ElseIf TT Like "*|*|*" = False And TT Like "*|*" Then
      Crr(Y(TT) + 2, 1) = Y(TT & "|1")
      Crr(Y(TT) + 2, 2) = Y(TT & "|2")
   ElseIf InStr(TT, "|") = 0 Then
      Crr(2, Y(TT) + 2) = TT
End If
i00: Next
Crr(1, 1) = "Group2": Crr(1, 2) = "LocnID": Crr(1, 3) = "TenderID"
Workbooks.Add
[A1].Resize(R + 2, C + 2) = Crr
[A1].Item(1, 3).Resize(1, C).Merge
[A1].Item(1, 3).HorizontalAlignment = xlCenter
Set Y = Nothing: Set Sh1 = Nothing: Set xR1 = Nothing: Erase Brr, Crr
End Sub

作者: maiko 時間: 2023-4-26 12:48

回復 6# Andy2483

謝謝Andy2483這麼多有用的教學，受教了！

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