[發問] 如何用VBA找尋數千條記錄？

maiko

下載 (93.68 KB)

2023-4-18 22:18

下載 (35.32 KB)

2023-4-18 22:18

TenderInventoryVV.rar (23.33 KB)

下載次數: 6

2023-4-18 22:18

感激各位賜教！

Andy2483

回復 1# maiko


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

執行提示1:

下載 (219.6 KB)

2023-4-19 10:53

執行提示2:

下載 (218.93 KB)

2023-4-19 10:53

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

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

執行結果:

下載 (219.37 KB)

2023-4-19 16:40

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

謝謝論壇,謝謝各位前輩
後學藉此帖練習與#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

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

執行結果:

下載 (166.67 KB)

2023-4-20 13:17

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

回復 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

回復 6# Andy2483


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