ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] ½Ð°ÝEXCEL VBA¬O§_¦³¿ìªk°µ¨ì¤Q¤j¶µ¥Øªº²Ó¶µ¥\¯à...?

[µo°Ý] ½Ð°ÝEXCEL VBA¬O§_¦³¿ìªk°µ¨ì¤Q¤j¶µ¥Øªº²Ó¶µ¥\¯à...?

¥»©«³Ì«á¥Ñ Haven ©ó 2016-3-23 02:34 ½s¿è

¦U¦ì¤j¤j¦n¡A¥ý¬°¥»¤Hªºªí¹F¯à¤O¤£¨¬¹Dºp...
¤p¾|¤u§@¤W»Ý¨D¡A»Ý­n±N¨C¤éªº²§±`¬ö¿ý¡õ

¾ã²z¦¨¥H¤Uªí®æªº®æ¦¡¡õ

·Q½Ð°Ý¬O§_¦³¿ìªk¥i±N¼Ï¯Ã¤ÀªRªíÂà´«¦¨¡u¾î¦¡¡v
(¡õ§â¼Ï¯Ã¦Û°ÊÅܦ¨)

(¡õÅܦ¨³oºØ¾î¦¡)

©Î¬OVBA¦³¿ìªk¦Û°Ê§ì¨ú©T©w¦ì¸mªº¼Æ¾Ú¨Ó¿z¿ï
ÁÙ¬O¦³¨ä¥L¤è¦¡¥i¥H¹F¦¨°ÆÀɪº¥Ø¼Ðªí®æ...
·PÁ¦U¦ìªº±Ð¾É!

ªþÀÉ¡G
EXCEL VBA µo°Ý.zip (21.58 KB)

¦^´_ 1# Haven
  1. Sub Test()
  2.     Dim ar, dMachines As Object, dTemp As Object
  3.     ar = [a1].CurrentRegion.Value
  4.     Set dMachines = CreateObject("scripting.dictionary")
  5.     For i = 2 To UBound(ar)
  6.         If Not dMachines.exists(ar(i, 2)) Then
  7.             Set dTemp = CreateObject("scripting.dictionary")
  8.             dMachines.Add ar(i, 2), dTemp
  9.         Else
  10.             Set dTemp = dMachines(ar(i, 2))
  11.         End If
  12.         dTemp(ar(i, 1)) = dTemp(ar(i, 1)) + 1
  13.     Next
  14.    
  15.     For Each x In dMachines.keys
  16.         s = ""
  17.         Set dTemp = dMachines(x)
  18.         For Each y In dTemp.keys
  19.             s = s & IIf(Len(s) = 0, "", ",") & y & "*" & dTemp(y)
  20.         Next
  21.         dMachines(x) = s
  22.     Next
  23.    
  24.     'Output
  25.     With Sheets.Add
  26.         .[b1].Resize(dMachines.Count) = Application.Transpose(dMachines.keys)
  27.         .[c1].Resize(dMachines.Count) = Application.Transpose(dMachines.items)
  28.         .[b1].Resize(dMachines.Count, 2).Sort .[b1]
  29.         .[a1].Value = Format(Now(), "m¤ëd¤é")
  30.         .[a1].Resize(dMachines.Count).Merge
  31.     End With
  32. End Sub
½Æ»s¥N½X
ªí¹F¤£²M¡BÃD·N¤£©ú½T¡B¨SªþÀɮ׮榡¡B¨S¦³°Q½×°ÝÃDªººA«×~~~~~~¥H¤W·R²ö¯à§U¡C

TOP

¤£¦n·N«ä¡Aªí¹F¯à¤O¯uªº¤ñ¸û®t...¨ä¹ê¤ñ¸û·Q°Ýªº¬O«ç»ò§â¸ê®Æ¥ý¤À¦¨«e¤Q¤j°ÝÃD³]³Æ¡A¦A°w¹ï«e¤Q¤j³]³Æªº¯Ê¥¢¶µ¥Ø±Æ¦¨³o¼Ëªº®æ¦¡QQ...

«Ü·PÁ¤j¤jªº±Ð¾Ç~!!!¯uªº·P¿E®÷¹s!!!
¤W­±ªºµ{¦¡±Æªk®Ä²v¯uªº¦n°ª!!

TOP

¦^´_ 2# stillfish00
µo¤å¤T¤ÀÄÁ¸T¤î­×§ïOrz

¤j¤j«D±`©êºp...
ÁÙ¤Ö¤F¤@¶µ±ø¥ó»Ý­n½Õ¾ã...

Åܦ¨³o¼Ë...

«Ü©êºp,³Ìªñ³£¨SºÎ¦n¤Ó°g½k...Orz

«ö·Ó²§±`ÀW²v³Ì°ªªº³]³Æ¨Ì§Ç±Æ¤ñ«á¿ï¥X«e¤Q¤j²§±`³]³Æ...
­«·sªþÀÉ...«D±`©êºpQQ
EXCELµo°Ý.zip (10.98 KB)

TOP

¦^´_ 4# Haven
  1. Sub Test()
  2.     Dim ar, dMachines As Object, dTemp As Object
  3.     ar = [a1].CurrentRegion.Value
  4.     Set dMachines = CreateObject("scripting.dictionary")
  5.     Set dBelong = CreateObject("scripting.dictionary")
  6.     For i = 2 To UBound(ar)
  7.         If Not dMachines.exists(ar(i, 3)) Then
  8.             Set dTemp = CreateObject("scripting.dictionary")
  9.             dMachines.Add ar(i, 3), dTemp
  10.         Else
  11.             Set dTemp = dMachines(ar(i, 3))
  12.         End If
  13.         dTemp(ar(i, 2)) = dTemp(ar(i, 2)) + 1
  14.         dBelong(ar(i, 3)) = ar(i, 1)
  15.     Next
  16.    
  17.     Dim s As String, cnt As Integer
  18.     For Each x In dMachines.keys
  19.         s = "": cnt = 0
  20.         Set dTemp = dMachines(x)
  21.         For Each y In dTemp.keys
  22.             s = s & IIf(Len(s) = 0, "", ",") & y & "*" & dTemp(y)
  23.             cnt = cnt + dTemp(y)
  24.         Next
  25.         dMachines(x) = Array(x, s, dBelong(x) & "³]³Æ²§±`", cnt)
  26.     Next
  27.    
  28.     'Output
  29.     With Sheets.Add
  30.         cnt = dMachines.Count
  31.         With .[a1]
  32.             .Cells(1, 2).Resize(cnt, 4) = Application.Transpose(Application.Transpose(dMachines.items))
  33.             .Resize(cnt, 5).Sort .Cells(1, 5), xlDescending ', , .Cells(1, 2), xlAscending
  34.             .Cells(1, 5).EntireColumn.ClearContents
  35.             If cnt > 10 Then
  36.                 .Offset(10).Resize(cnt - 10, 4).ClearContents
  37.                 cnt = 10
  38.             End If
  39.             .Value = Format(Now(), "m¤ëd¤é")
  40.             .Resize(cnt).Merge
  41.         End With
  42.     End With
  43. End Sub
½Æ»s¥N½X
ªí¹F¤£²M¡BÃD·N¤£©ú½T¡B¨SªþÀɮ׮榡¡B¨S¦³°Q½×°ÝÃDªººA«×~~~~~~¥H¤W·R²ö¯à§U¡C

TOP

·PÁ¤j¤j«ü¾É...«e°}¤l¤u§@ªº¦a¤è¨S¿ìªk¤Wºô...
¤@ª½¨S¦^À³«Ü©êºp...ʨ

TOP

¤£¦n·N«ä ¦h¦¸³Â·Ð...·Q¦A¦¸¸ß°Ý...§Ú¥Î¤j¤jªº½s½X°µ¾ã²z
³Ìªñµo²{¡A¦ü¥G¦³¸õ¦W¦¸ªºª¬ªp¥X²{
¤U¹Ï¥ªÃä¬O¤j¤jªº½s½X©Ò±Æ¥Xªº«e¤Q¤jNG³]³Æ¡A¥kÃä¬O¼Ï¯Ã¤ÀªRªí±Æ¥Xªº¤Q¤jNG³]³Æ

³Ì¥kÃ䪺¬O³]³Æªº±Æ¦W...
  1. Dim ar, dMachines As Object, dTemp As Object
  2.     ar = [a1].CurrentRegion.Value
  3.     Set dMachines = CreateObject("scripting.dictionary")
  4.     Set dBelong = CreateObject("scripting.dictionary")
  5.     For i = 2 To UBound(ar)
  6.         If Not dMachines.exists(ar(i, 3)) Then
  7.             Set dTemp = CreateObject("scripting.dictionary")
  8.             dMachines.Add ar(i, 3), dTemp
  9.         Else
  10.             Set dTemp = dMachines(ar(i, 3))
  11.         End If
  12.         dTemp(ar(i, 2)) = dTemp(ar(i, 2)) + 1
  13.         dBelong(ar(i, 3)) = ar(i, 1)
  14.     Next
  15.    
  16.     Dim s As String, cnt As Integer
  17.     For Each x In dMachines.keys
  18.         s = "": cnt = 0
  19.         Set dTemp = dMachines(x)
  20.         For Each y In dTemp.keys
  21.             s = s & IIf(Len(s) = 0, "", ",") & y & "*" & dTemp(y)
  22.             cnt = cnt + dTemp(y)
  23.         Next
  24.         dMachines(x) = Array(x, s, "·Ð½Ð" & dBelong(x) & "¨ó§U½T»{³]³Æ±¡§Î", cnt)
  25.     Next
  26.    
  27.     'Output
  28.     With Sheets.Add
  29.     ActiveSheet.Name = "NG³]³Æ(ªí®æ)"
  30.         cnt = dMachines.Count
  31.         With .[a1]
  32.             .Cells(1, 2).Resize(cnt, 4) = Application.Transpose(Application.Transpose(dMachines.items))
  33.             .Resize(cnt, 5).Sort .Cells(1, 5), xlDescending ', , .Cells(1, 2), xlAscending
  34.             .Cells(1, 5).EntireColumn.ClearContents
  35.             If cnt > 10 Then
  36.                 .Offset(10).Resize(cnt - 10, 4).ClearContents
  37.                 cnt = 10
  38.             End If
  39.             .Value = Format(Now() - 1, "m¤ëd¤é")
  40.             .Resize(cnt).Merge
  41.         End With
  42.     End With
½Æ»s¥N½X
¥Ø«e¬O¦³¤p§ï½s½X...
½Ð°Ý¤j¤j³o¼Ëªºª¬ªp¸Ó¦p¦ó¸ÑQQ?

PS.©êºp¹ê»Ú³]³Æ¦WºÙ¦]«O±K±ø¬ù±oÁקK¤½¶}...³y¦¨¤£«K«Ü©êºp...

TOP

¤w¸Ñ¨M...·PÁÂQQ

TOP

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


°õ¦æµ²ªG:


Option Explicit
Sub TEST()
Dim Brr, Crr, A, Z, B, i&, R&, T$, T1$, T2$, T3$
Application.DisplayAlerts = False
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([C1], [A65536].End(3))
For i = 2 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3)
   If Not IsObject(Z(T3)) Then Set Z(T3) = CreateObject("Scripting.Dictionary"): Z(T3 & "/s") = Brr(i, 1)
   Set A = Z(T3): A(T2) = A(T2) + 1: Set Z(T3) = A: Z(T3 & "/n") = Z(T3 & "/n") + 1
Next
ReDim Crr(1 To 1000, 3)
For Each A In Z.KEYS
   If Not IsObject(Z(A)) Then GoTo A01 Else R = R + 1
   For Each B In Z(A).KEYS: T = T & "," & B & "*" & Z(A)(B): Next
   Crr(R, 0) = Z(A & "/n")
   Crr(R, 1) = A
   Crr(R, 2) = Mid(T, 2): T = ""
   Crr(R, 3) = Z(A & "/s") & "³]³Æ²§±`"
A01: Next
If R = 0 Then Exit Sub Else [E15].Resize(R, 4).Delete
With [E15].Resize(R, 4)
   .Value = Crr
   .Sort KEY1:=.Item(1), Order1:=2, Header:=2
   .Offset(10).Delete
   .Item(1).Resize(10).Merge: .Item(1) = Date
   [E15].Resize(10, 4).Borders.LineStyle = 1
End With
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : «H¤ß¡B¼Ý¤O¡B«i®ð¤TªÌ¨ã³Æ¡A«h¤Ñ¤U¨S¦³°µ¤£¦¨ªº¨Æ¡C
ªð¦^¦Cªí ¤W¤@¥DÃD