¨Ì¤é´Á¨Ó¤À§O²Î­p¤½¥q¤H¼Æ

sillykin

¨Ì¤é´Á¨Ó¤À§O²Î­p¤½¥q¤H¼Æ,¤£ª¾¥Î¨º¤@­Ó¨ç¼Æ¨Ó²Î­p

Andy2483

¦^´_ 4# ­ã´£³¡ªL


    ÁÂÁ«e½ú
Option Explicit
Sub ²Î­p¦U¤é´Á_¦U¤½¥q¤H¼Æ_±Æ°£­«½Æ_2()
Dim i&, C&, N&, N2&, N6&, R%, k%, T2$, T4$, T6$, TT$
Dim S(2), Crr, Y, Sha, Sh1, Sh2
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("¸ê®Æ®w")
Set Sh2 = Sheets("Á`ªí³æ")
Set Sha = Range(Sh1.[A3], Sh1.Cells(Sh1.Cells.SpecialCells(xlLastCell).Row, "G"))
S(1) = Sha '°}¦C¤¤°}¦C,¤µ¤Ñ­è¾Ç¨ìªº http://forum.twbts.com/thread-23571-1-1.html
S(2) = Sha.Offset(, 8) '°}¦C¤¤°}¦C
N = Sha.Rows.Count
Sh2.UsedRange.EntireRow.Delete
ReDim Crr(10000, N) '±q0,0¶}©l
For k = 1 To 2
   For i = 1 To N
      T2 = Trim(S(k)(i, 2)): T4 = Trim(S(k)(i, 4)): T6 = Trim(S(k)(i, 6))
      TT = "|" & T2 & "|" & T4 & "|" & T6 & "|"
      If InStr(TT, Application.Rept("|", 2)) Then GoTo PP '±Æ°£ªÅ®æ
      If Y.Exists(TT) Then GoTo PP '±Æ°£­«½Æ
      If Not Y.Exists(T2 & "|C") Then
         Y(T2 & "|C") = N2
         Crr(0, N2 + 1) = T2 '¼ÐÃD¦C
         N2 = N2 + 1
      End If
      If Not Y.Exists(T6 & "|R") Then
         Y(T6 & "|R") = N6
         Crr(N6 + 1, 0) = T6 '¼ÐÃDÄæ
         N6 = N6 + 1
      End If
      R = Y(T6 & "|R"): C = Y(T2 & "|C")
      Crr(R + 1, C + 1) = Crr(R + 1, C + 1) + 1 '²Ö¥[¼Æ¶q
      Y(TT) = 1 '¼Ð°O¦s¦b
PP:
   Next
Next
With Sh2.[A1].Resize(N6 + 1, N2 + 1)
   .Value = Crr
   .Offset(, 1).Sort Key1:=.Cells(1, 2), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   .Offset(1).Sort Key1:=.Cells(2, 1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
   .Borders.LineStyle = 1
End With
Set Y = Nothing: Set Crr = Nothing: Erase S
End Sub

Andy2483

¦^´_ 5# Andy2483


    ²Î­p¦U¤é´Á_¦U¤½¥q¤H¼Æ_±Æ°£­«½Æ

¸ê®Æ®w:

¤U¸ü (236.97 KB)

2023-1-4 10:52

Á`ªí³æ_²M°£¸ê®Æ:

¤U¸ü (59.75 KB)

2023-1-4 10:52

°õ¦æµ²ªG:

¤U¸ü (76.36 KB)

2023-1-4 10:53

Option Explicit
Sub ²Î­p¦U¤é´Á_¦U¤½¥q¤H¼Æ_±Æ°£­«½Æ_1()
Dim i&, u&, C&, R&, v&, Shr&, T2$, T4$, T6$, TT$
Dim Arr, Crr, Y, Z, xR, Sh1, Sh2, Sha
Set Z = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("¸ê®Æ®w")
Set Sh2 = Sheets("Á`ªí³æ")
Set Sha = Sh1.Range("A3:G" & Split(Sh1.UsedRange.Address, "$")(4))
Shr = Sha.Rows.Count
Sha.Copy Sh2.[A1]
Sha.Offset(, 8).Copy Sh2.Cells(Shr + 1, 1)
With Sh2.UsedRange
    .Replace What:=" ", Replacement:="", LookAt:=xlPart
    .Sort _
      KEY1:=.Item(6), Order1:=xlAscending, _
      Key2:=.Item(2), Order2:=xlAscending, _
      Header:=xlNo, Orientation:=xlTopToBottom
    Arr = .Value
    .EntireRow.Delete
End With
For i = 1 To UBound(Arr)
   If Not Z.Exists(Arr(i, 6)) And Arr(i, 6) <> "" Then
      Z(Arr(i, 6)) = Z.Count + 1
   End If
   If Not Y.Exists(Arr(i, 2)) And Arr(i, 2) <> "" Then
      Y(Arr(i, 2)) = Y.Count + 1
   End If
Next
R = Z.Count
Sh2.[A2].Resize(R, 1) = Application.Transpose(Z.KEYS)
C = Y.Count
Sh2.[B1].Resize(1, C) = Y.KEYS
ReDim Crr(R, C)
For i = 1 To UBound(Arr)
   T2 = Arr(i, 2)
   T4 = Trim(Arr(i, 4))
   T6 = Trim(Arr(i, 6))
   TT = T2 & "|" & T4 & "|" & T6 & "|"
   If Y.Exists(TT) Then GoTo PP
   If Y(T2) <> "" And Z(T6) <> "" And T4 <> "" Then
      v = Z(Arr(i, 6)) - 1: u = Y(Arr(i, 2)) - 1
      Crr(v, u) = Crr(v, u) + 1
      Y(TT) = 1
   End If
PP:
Next
Sh2.[B2].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
Sh2.Range(Sh2.[A1], Sh2.Cells(R + 1, C + 1)).Borders.LineStyle = 1
Application.Goto Sh2.[A1]
Set Y = Nothing
Set Z = Nothing
Set Arr = Nothing
Set Crr = Nothing
End Sub

Andy2483

¦^´_ 1# sillykin


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹¥DÃD¾Ç²ß¦r¨å»P°}¦C±o¨ì¦hºØª¾ÃÑ»P¸gÅç,¥H¤U¬O«á¾Ç½m²ßVBA¤è¦¡ªº¤è®×,½Ð«e½ú°Ñ¦Ò
½Ð«e½ú­Ì«ü¾É,ÁÂÁÂ

°õ¦æ«e:

¤U¸ü (86.98 KB)

2023-1-3 15:01

µ²ªG»Pĵ°T1:

¤U¸ü (91.5 KB)

2023-1-3 15:01

µ²ªG»Pĵ°T2:

¤U¸ü (92.3 KB)

2023-1-3 15:02

Option Explicit
Sub ¨Ì¤é´Á¨Ó¤À§O²Î­p¤½¥q¤H¼Æ_20230103_1()
Dim R&, i&, j&, N&, Q&, T1$, T2$, T4$, Qv$, Y, Brr, Crr, C, Sh1, Sh2
'¡ô«Å§iÅܼÆ:(R,i,j,N,Q)¬Oªø¾ã¼ÆÅܼÆ,(T1,T2,T4,Qv)¬O¦r¦êÅܼÆ,¨ä¥¦¬O³q¥Î«¬ÅܼÆ
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OY¬O ¦r¨å
Set Sh1 = Sheets("¸ê®Æ®w")
'¡ô¥OSh1¬O "¸ê®Æ®w"¤u§@ªí
Set Sh2 = Sheets("Á`ªí³æ")
'¡ô¥OSh2¬O "Á`ªí³æ"¤u§@ªí
Brr = Sh1.Range("A3:N" & Split(Sh1.UsedRange.Address, "$")(4))
'¡ô¥OBrr¬O¤Gºû°}¦C!­Ë¤J[A3]¨ìNÄæ³Ì«á¦CÀx¦s®æ
R = Sh2.Cells(Rows.Count, "A").End(3).Row
'¡ô¥OR³o¾ã¼ÆÅܼƬO "Á`ªí³æ"¤u§@ªíAÄæ³Ì«á¦³¤º®eÀx¦s®æ¦C¸¹
C = Sh2.Cells(1, Columns.Count).End(1).Column
'¡ô¥OC³o¾ã¼ÆÅܼƬO "Á`ªí³æ"¤u§@ªí²Ä1¦C³Ì¥k°¼¦³¤º®eÀx¦s®æÄ渹
Range(Sh2.Cells(R, 1), Sh2.Cells(1, C)).Offset(1, 1).ClearContents
'¡ô¥O"Á`ªí³æ"¤u§@ªí[A1]¨ìR¦CCÄæÀx¦s®æ½d³ò°¾²¾©¹¤U1¦C,°¾²¾©¹¥k1ÄæÀx¦s®æ­È²M°£
Crr = Range(Sh2.Cells(R, 1), Sh2.Cells(1, C))
'¡ô¥OCrr¬O¤Gºû°}¦C!­Ë¤J"Á`ªí³æ"¤u§@ªí[A1]¨ìR¦CCÄæÀx¦s®æ­È
For i = 2 To UBound(Crr, 2)
'¡ô³]¶¶°j°é!i±q2¨ìCrr°}¦C¾î¦V³Ì¤j¯Á¤ÞÄ渹¼Æ
   Y(Crr(1, i) & "|C") = i
   '¡ô¥O1¦Ci°j°éÄæCrr°}¦C­È³s±µ"|C"·íkey,item¬Oi°j°é¼Æ,©ñ¤JY¦r¨å¸Ì
Next
For i = 2 To UBound(Crr)
'¡ô³]¶¶°j°é!i±q2¨ìCrr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹¼Æ
   Y(Crr(i, 1) & "|R") = i
   '¡ô¥Oi°j°é¦C1ÄæCrr°}¦C­È³s±µ"|R"·íkey,item¬Oi°j°é¼Æ,©ñ¤JY¦r¨å¸Ì
Next
For Each C In [{2,10}]
'¡ô³]¶¶°j°é!¥OC¬O¤@ºû°}¦C¸Ìªº¤@­û
   For R = 1 To UBound(Brr)
   '¡ô³]¶¶°j°é!¥OR±q1¨ìBrr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹¼Æ
      T1 = Trim(Brr(R, C))
      '¡ô¥OT1¬O R°j°é¦CC°j°éÄæBrr°}¦C­È¥h°£¦r¦êÀY§ÀªºªÅ¥Õ¦r¤¸
      T2 = Trim(Brr(R, C + 2))
      '¡ô¥OT2¬O R°j°é¦CC+2°j°éÄæBrr°}¦C­È¥h°£¦r¦êÀY§ÀªºªÅ¥Õ¦r¤¸
      T4 = Trim(Brr(R, C + 4))
      '¡ô¥OT4¬O R°j°é¦CC+4°j°éÄæBrr°}¦C­È¥h°£¦r¦êÀY§ÀªºªÅ¥Õ¦r¤¸
      If T1 = "" Or T4 = "" Then GoTo PS
      '¡ô¦pªGT1¦r¦êÅܼƬOªÅ¦r¤¸©Î ¦pªGT4¦r¦êÅܼƬOªÅ¦r¤¸,´N¸õ¨ìPS:¦ì¸mÄ~Äò°õ¦æ
      If Y(T1 & "|C") <> "" And Y(T4 & "|R") <> "" Then
      '¡ô¦pªG¥ÎT1ÅܼƳs±µ"|C"¬dY¦r¨å¤£¬OªÅ¦r¤¸ ¦Ó¥B ¥ÎT4ÅܼƳs±µ"|R"¬dY¦r¨å¤£¬OªÅ¦r¤¸??
         If T2 <> "" Then
         '¡ô¦pªGT2ÅܼƤ£¬OªÅ¦r¤¸?
            i = Y(Trim(Brr(R, C + 4)) & "|R"): j = Y(Trim(Brr(R, C)) & "|C")
            '¡ô¥Oi¬O ¥Ó½Ð¤é¥h°£ÀY§ÀªÅ¥Õ¦r¤¸«á³s±µ"|R"¬dY¦r¨å±o¨ìªºitem­È
            '¡ô¥Oj¬O ³æ¦ì/¤ÀªÀ¥h°£ÀY§ÀªÅ¥Õ¦r¤¸«á³s±µ"|C"¬dY¦r¨å±o¨ìªºitem­È
            Crr(i, j) = Crr(i, j) + 1
            '¡ô¥Oi¦CjÄæCrr°}¦C­È +1
            Else
               N = N + 1
               '¡ô§_«h¥ON¾ã¼ÆÅܼÆ+1
         End If
         ElseIf Y(T1 & "|C") = "" And Y(T4 & "|R") <> "" Then
         '¡ô§_«h¦pªGT1¦r¦êÅܼƳs±µ"|C"¬dY¦r¨å¦aitem­È¬OªÅ¦r¤¸,
         '¦Ó¥BT4¦r¦êÅܼƳs±µ"|R"¬dY¦r¨å¤£¬OªÅ¦r¤¸
            Q = Q + 1
            '¡ô¥OQ¾ã¼ÆÅܼÆ+1
            Qv = Qv & "," & T1
            '¡ô¥OQv³o¦r¦êÅܼƬO ¦Û¨­­È³s±µ",",¦A³s±µT1¦r¦êÅܼÆ
      End If
PS:
   Next
Next
Sh2.[A1].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
'¡ô¥O"Á`ªí³æ"¤u§@ªí¦V¤UÂX®iCrr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹¼Æ,
'¦V¥kCrr°}¦C¾î¦V³Ì¤j¯Á¤ÞÄ渹¼Æ,³o½d³òÀx¦s®æ­È¥HCrr°}¦C­È±a¤J
Application.Goto Sh2.[A1]
'¡ô¥OÀx¦s®æ´å¼Ð¸õ¨ì "Á`ªí³æ"¤u§@ªí[A1]
If N > 0 Then MsgBox "¦@¦³ " & N & "µ§¸ê®Æ¨S¦³©m¦W,¥¼¦C¤J²Î­p"
If Q > 0 Then MsgBox "¦@¦³ " & Q & "³æ¦ì/¤ÀªÀ¦b Á`ªí³æ§ä¤£¨ì" & Qv
Set Y = Nothing
Set Brr = Nothing
Set Crr = Nothing
'¡ôÄÀ©ñÅܼÆ
End Sub

­ã´£³¡ªL

=SUMPRODUCT((¸ê®Æ®w!$B$2:$B$600=B$1)*(¸ê®Æ®w!$F$2:$F$600=$A2)+(¸ê®Æ®w!$J$2:$J$600=B$1)*(¸ê®Æ®w!$N$2:$N$600=$A2))

¤½¦¡¸ûªø, ¦ý¤½¦¡­pºâ¶q¤Ö~~

hcm19522

=SUMPRODUCT((¸ê®Æ®w!$B$3:$J$999=B$1)*(¸ê®Æ®w!$F$3:$N$999=$A2))

jcchiang

¦^´_ 1# sillykin
B2¥k©Ô=SUM(SUMPRODUCT((¸ê®Æ®w!$B:$B=Á`ªí³æ!B$1)*(¸ê®Æ®w!$F:$F=Á`ªí³æ!$A$2)),SUMPRODUCT((¸ê®Æ®w!$J:$J=Á`ªí³æ!B$1)*(¸ê®Æ®w!$N:$N=Á`ªí³æ!$A$2)))