[發問] 請問EXCEL VBA是否有辦法做到十大項目的細項功能...?

Haven

各位大大好，先為本人的表達能力不足道歉...
小魯工作上需求，需要將每日的異常紀錄↓

下載 (64.89 KB)

2016-3-23 02:29

整理成以下表格的格式↓

下載 (48.63 KB)

2016-3-23 02:28

想請問是否有辦法可將樞紐分析表轉換成「橫式」
(↓把樞紐自動變成)

下載 (52.78 KB)
樞紐

2016-3-23 02:30

(↓變成這種橫式)

下載 (58.67 KB)

2016-3-23 02:28

或是VBA有辦法自動抓取固定位置的數據來篩選
還是有其他方式可以達成副檔的目標表格...
感謝各位的教導!

附檔：
EXCEL VBA 發問.zip (21.58 KB)

NG品項十大機台
下載次數: 15

2016-3-23 02:15

stillfish00

回復 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

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

很感謝大大的教學~!!!真的感激涕零!!!
上面的程式排法效率真的好高!!

Haven

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

大大非常抱歉...
還少了一項條件需要調整...

下載 (257.01 KB)

2016-3-24 11:54

變成這樣...

下載 (64.67 KB)

2016-3-24 11:55

很抱歉,最近都沒睡好太迷糊...Orz

按照異常頻率最高的設備依序排比後選出前十大異常設備...
重新附檔...非常抱歉QQ
EXCEL發問.zip (10.98 KB)

下載次數: 10

2016-3-24 11:58

stillfish00

回復 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

感謝大大指導...前陣子工作的地方沒辦法上網...
一直沒回應很抱歉...囧

Haven

不好意思 多次麻煩...想再次詢問...我用大大的編碼做整理
最近發現，似乎有跳名次的狀況出現
下圖左邊是大大的編碼所排出的前十大NG設備，右邊是樞紐分析表排出的十大NG設備

下載 (33.28 KB)
跳名次

2016-4-12 08:31

最右邊的是設備的排名...

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

已解決...感謝QQ

Andy2483

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

下載 (174.93 KB)

2024-1-12 16:39

執行結果:

下載 (226.38 KB)

2024-1-12 16:39

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