Board logo

標題: [發問] 請問EXCEL VBA是否有辦法做到十大項目的細項功能...? [打印本頁]
作者: Haven    時間: 2016-3-23 02:33     標題: 請問EXCEL VBA是否有辦法做到十大項目的細項功能...?

本帖最後由 Haven 於 2016-3-23 02:34 編輯

各位大大好，先為本人的表達能力不足道歉...
小魯工作上需求，需要將每日的異常紀錄↓
[attach]23535[/attach]
整理成以下表格的格式↓
[attach]23533[/attach]
想請問是否有辦法可將樞紐分析表轉換成「橫式」
(↓把樞紐自動變成)
[attach]23536[/attach]
(↓變成這種橫式)
[attach]23534[/attach]
或是VBA有辦法自動抓取固定位置的數據來篩選
還是有其他方式可以達成副檔的目標表格...
感謝各位的教導!

附檔：
[attach]23532[/attach]
作者: stillfish00    時間: 2016-3-23 10:34

回復 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
複製代碼
作者: Haven    時間: 2016-3-24 10:48

不好意思，表達能力真的比較差...其實比較想問的是怎麼把資料先分成前十大問題設備，再針對前十大設備的缺失項目排成這樣的格式QQ...

很感謝大大的教學~!!!真的感激涕零!!!
上面的程式排法效率真的好高!!
作者: Haven    時間: 2016-3-24 12:00

回復 2# stillfish00
發文三分鐘禁止修改Orz

大大非常抱歉...
還少了一項條件需要調整...
[attach]23552[/attach]
變成這樣...
[attach]23553[/attach]
很抱歉,最近都沒睡好太迷糊...Orz

按照異常頻率最高的設備依序排比後選出前十大異常設備...
重新附檔...非常抱歉QQ
[attach]23554[/attach]
作者: stillfish00    時間: 2016-3-24 17:27

回復 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
複製代碼
作者: Haven    時間: 2016-4-5 13:17

感謝大大指導...前陣子工作的地方沒辦法上網...
一直沒回應很抱歉...囧
作者: Haven    時間: 2016-4-12 08:36

不好意思 多次麻煩...想再次詢問...我用大大的編碼做整理
最近發現，似乎有跳名次的狀況出現
下圖左邊是大大的編碼所排出的前十大NG設備，右邊是樞紐分析表排出的十大NG設備
[attach]23815[/attach]
最右邊的是設備的排名...
  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) & "協助確認設備情形", 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
複製代碼
目前是有小改編碼...
請問大大這樣的狀況該如何解QQ?

PS.抱歉實際設備名稱因保密條約得避免公開...造成不便很抱歉...
作者: Haven    時間: 2016-4-13 17:08

已解決...感謝QQ
作者: Andy2483    時間: 2024-1-12 16:40

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典中的字典,學習方案如下,請各位前輩指教
執行前:
[attach]37289[/attach]

執行結果:
[attach]37290[/attach]

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)