[µo°Ý] ¦p¦ó¥ÎVBA§ä´M¼Æ¤d±ø°O¿ý¡H

maiko

¤U¸ü (93.68 KB)

2023-4-18 22:18

¤U¸ü (35.32 KB)

2023-4-18 22:18

TenderInventoryVV.rar (23.33 KB)

¤U¸ü¦¸¼Æ: 6

2023-4-18 22:18

·P¿E¦U¦ì½ç±Ð¡I

Andy2483

¦^´_ 1# maiko


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò,ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

°õ¦æ´£¥Ü1:

¤U¸ü (219.6 KB)

2023-4-19 10:53

°õ¦æ´£¥Ü2:

¤U¸ü (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 & " ­Ó²Õ¦X¨S¦³¸ê®Æ!" & 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 & " ­Ó²Õ¦X¸ê®Æ®w§ä¤£¨ì!"
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Set xR1 = Nothing
Set xR2 = Nothing: Erase Brr, Crr
End Sub

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾Ç¤@¶}©l¨S¬Ý²M·¡ÃD·N,°µ¤F­Ó²Õ¦Xªº²Î­p,¾Ç²ßªº¤è®×¤]©ñ¤W¨Ó,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æµ²ªG:

¤U¸ü (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 & " ­Ó²Õ¦X¨S¦³³Q²Î­p!" & 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 & " ­Ó²Õ¦X¸ê®Æ®w§ä¤£¨ì!"
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Set xR1 = Nothing
Set xR2 = Nothing: Erase Brr, Crr
End Sub

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß»P#2¼Óµ{§ÇÄA­Ëªº¤è¦¡,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

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

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æµ²ªG:

¤U¸ü (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


    ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
¦^´_¦Û¤v¬Q¤Ñªº¤£¨D¬Æ¸Ñ,¤£¥ÎSplit()¤À³Îkey«á¥N¤J¼ÐÃDÄæ,ª½±µ¥H¦r¨åitem±a¤J¼ÐÃDÄæ
½Ð¦U¦ì«e½ú«ü±Ð



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³o»ò¦h¦³¥Îªº±Ð¾Ç¡A¨ü±Ð¤F¡I