b9208

¦^´_ 11# n7822123
Às¤j
«D±`·PÁÂ
°õ¦æok

­ã´£³¡ªL

¦^´_ 10# b9208

Sub TEST_T()
Dim Arr, Brr, Crr, xD, i&, K, R&, C&, N1&, N2&
Set xD = CreateObject("Scripting.Dictionary")
[¤u§@ªí2!B7:B2000].EntireRow.Delete
Arr = [¤u§@ªí2!B6:K6]
For i = 2 To UBound(Arr, 2): xD(Arr(1, i)) = i: Next
Arr = Range([¸ê®Æ!A1], Sheets("¸ê®Æ").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11):  Crr = Brr
For i = 5 To UBound(Arr)
    K = Arr(i, 2): If K = "" Then GoTo 101
    R = Val(xD(K)): C = Val(xD(Arr(i, 8)))
    If C > 0 Then
       If R = 0 Then N1 = N1 + 1: R = N1: xD(K) = R: Brr(R, 1) = K
       Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
    End If
    '--------------------------------
    R = Val(xD(K & "/")): C = Val(xD(Arr(i, 9)))
    If C > 0 Then
       If R = 0 Then N2 = N2 + 1: R = N2: xD(K & "/") = R: Crr(R, 1) = K
       Crr(R, C) = Crr(R, C) + 1: Crr(R, 11) = Crr(R, 11) + 1
    End If
101: Next i
With [¤u§@ªí2!B7].Resize(N1, 11)
     .Value = Brr
     .Borders.LineStyle = 1
End With
With [¤u§@ªí2!P7].Resize(N2, 11)
     .Value = Crr
     .Borders.LineStyle = 1
End With
End Sub

¤À¶}¼g¸û¦n¸ÑŪ~~


==============================

n7822123

¦^´_ 10# b9208

À|¸Õ©ó¤u§@ªí2¦P®É¿é¥X¤J¤f¤Î¥X¤f²Î­pªí¡Aµ{¦¡°õ¦æ¿ù»~

¦]¬°¤u§@ªí Outq ªºªí®æ¥ª¤WÁÙ¬O[B6] ¸ò¤u§@ªí2 ¤J¤fªí®æ¤@­P

¦ý¬O¤u§@ªí2  ¥X¤fªí®æ¥ª¤WÅܦ¨ [P6] ¡A·Ç¤jªºµ{¦¡­n¦A­×§ï¦ì¸m¤~¯à¥¿±`°õ¦æ

¤£¹L¥X¤f¤J¤fµ{¦¡ÅÞ¿è¤@¼Ë¡A¥u¦³§ìªº¦ì¸m»P¿é¥Xªº¦ì¸m¤£¦P¡A§Úı±o¨S¥²­n§ï2¬qµ{¦¡

¥X¤f¡B¤J¤f¥i¥H¦X¨Ö¼g¡A§Ú¤]¦Û¤v¼g¤F¤@¬q¡A¨Ã¥[¤j¼u©Ê

N1~N4, S1~S5 ¶¶§ÇÀH«Kµ¹¤]¨SÃö«Y¡A³£¥i¥H§äªº¨ì¹ïÀ³¡A¥i¥H°Ñ¦Ò¬Ý¬Ý

µ{¦¡¦p¤U

Sub ²Î­p¤J¤f()
[B6].CurrentRegion.Offset(2).Clear
²Î­p [B6], 8
End Sub
Sub ²Î­p¥X¤f()
[P6].CurrentRegion.Offset(2).Clear
²Î­p [P6], 9
End Sub
Sub ²Î­p(ByVal cel0 As Range, Ci As Long)
Dim D, Arr, Brr, T$, K1$, K2$, Key, R&, Ro&, Co&, Rg As Range
Set D = CreateObject("Scripting.Dictionary")
Arr = [¸ê®Æ!A4].CurrentRegion
For R = 2 To UBound(Arr)
  K1 = Arr(R, 2): K2 = Arr(R, Ci)
  If K1 <> T Then Ro = Ro + 1: D(K1) = Ro: T = K1
  If K2 <> "" Then Key = K1 & "-" & K2: D(Key) = D(Key) + 1
Next
ReDim Brr(1 To Ro, 1 To 11)
For Each Key In D.keys
  If InStr(Key, "-") = 0 Then Brr(D(Key), 1) = Key: GoTo ¤U­ÓKey
  Ro = D(Split(Key, "-")(0))
  Set Rg = cel0.Resize(, 10).Find(Split(Key, "-")(1), , , xlWhole)
  If Not Rg Is Nothing Then
    Co = Rg.Column - cel0.Column + 1
    Brr(Ro, Co) = D(Key): Brr(Ro, 11) = Brr(Ro, 11) + D(Key)
  End If
¤U­ÓKey: Next
With cel0(2).Resize(Ro, 11)
  .Value = Brr: .Borders.LineStyle = 1
  .VerticalAlignment = xlBottom
  .HorizontalAlignment = xlCenter
End With
End Sub

Àɮצp¤U

W2-0822.rar (62.23 KB)

¤U¸ü¦¸¼Æ: 3

2020-8-22 01:11

b9208

¦^´_ 8# ­ã´£³¡ªL
ª©¥D ±z¦n
°Ñ¦Òª©¥D¤§µ{¦¡½X¡A©ó¥t¤u§@ªí(Outq) ²Î­p¥X¤f¬OOKªº¡C
À|¸Õ©ó¤u§@ªí2¦P®É¿é¥X¤J¤f¤Î¥X¤f²Î­pªí¡Aµ{¦¡°õ¦æ¿ù»~¡AÀµ½Ðª©¥D«ü¾É¡C
«D±`·PÁÂ
W2.rar (65.42 KB)

¤U¸ü¦¸¼Æ: 5

2020-8-21 21:06

b9208

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

µ{¦¡°õ¦æOK
²Å¦X´Á±æ
«D±`·PÁ±z

­ã´£³¡ªL

Sub TEST()
Dim Arr, Brr, xD, i&, j%, K, R&, C&, N&
Set xD = CreateObject("Scripting.Dictionary")
[¤u§@ªí2!B7:B2000].EntireRow.Delete
Arr = [¤u§@ªí2!B6:K6]
For j = 2 To UBound(Arr, 2): xD(Arr(1, j)) = j: Next
Arr = Range([¸ê®Æ!A1], Sheets("¸ê®Æ").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11)
For i = 5 To UBound(Arr)
    K = Arr(i, 2): R = Val(xD(K)): C = Val(xD(Arr(i, 8)))
    If K = "" Or C = 0 Then GoTo 101
    If R = 0 Then N = N + 1: R = N: xD(K) = N: Brr(N, 1) = K
    Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
101: Next i
With [¤u§@ªí2!B7].Resize(N, 11)
     .Value = Brr
     .Borders.LineStyle = 1
End With
End Sub

Xl0000221.rar (21.58 KB)

¤U¸ü¦¸¼Æ: 13

2020-8-21 12:47

=====================

b9208

¦^´_ 6# jcchiang
«D±`·PÁ¨ó§U»P«ü¾É
µ{¦¡°õ¦æOK
¦ý¡u¤u§@ªí2¡v¤§¤é´Á¡A¬O¨Ì¾Ú¡u¸ê®Æ¡v¤º¤é´Á¿é¥X¤£­«´_¤é´Á¡A¨Ã«D¨Æ¥ý¿é¤Jªº¡C

jcchiang

¦^´_ 3# b9208

¸Õ¸Õ¬Ý
    Sub ex()
Dim arr
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = Sheets("¸ê®Æ").[B5].CurrentRegion
For i = 2 To UBound(arr)
   If Not d.Exists(arr(i, 2) & arr(i, 8)) Then
      d.Add (arr(i, 2) & arr(i, 8)), 1
   Else
      d(arr(i, 2) & arr(i, 8)) = d(arr(i, 2) & arr(i, 8)) + 1
   End If
Next
With Sheets(1)
arr = .[B6].CurrentRegion
For i = 2 To UBound(arr, 2) - 1
   For j = 2 To UBound(arr)
      If d(arr(j, 1) & arr(1, i)) = "" Then
         arr(j, i) = 0
      Else
         arr(j, i) = d(arr(j, 1) & arr(1, i))
      End If
   Next
Next
.[B6].CurrentRegion = arr
.[L7].Resize(UBound(arr) - 1) = "=sum(c7:K7)"
.[L:L] = .[L:L].Value
End With
Set d = Nothing
End Sub

b9208

¦^´_ 4# ­ã´£³¡ªL
©T©w¤£ÅÜ
ÁÂÁÂ

­ã´£³¡ªL

²Ä6¦æªº N1~N4, S1~S5 ¬O©T©w¤£Åܪº???