返回列表 上一主題 發帖

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

Haven

帖子
6 
主題
1 
精華
0 
積分
15 
點名
0  
作業系統
Win2000 
軟體版本
Excel2010 
閱讀權限
10 
性別
男 
註冊時間
2016-3-22 
最後登錄
2022-7-19 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2016-3-23 02:33 | 只看該作者

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

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

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

整理成以下表格的格式↓

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

(↓變成這種橫式)

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

附檔：
EXCEL VBA 發問.zip (21.58 KB)
收藏 分享

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

Haven

帖子
6 
主題
1 
精華
0 
積分
15 
點名
0  
作業系統
Win2000 
軟體版本
Excel2010 
閱讀權限
10 
性別
男 
註冊時間
2016-3-22 
最後登錄
2022-7-19 
3#
發表於 2016-3-24 10:48 | 只看該作者
不好意思，表達能力真的比較差...其實比較想問的是怎麼把資料先分成前十大問題設備，再針對前十大設備的缺失項目排成這樣的格式QQ...

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

TOP

Haven

帖子
6 
主題
1 
精華
0 
積分
15 
點名
0  
作業系統
Win2000 
軟體版本
Excel2010 
閱讀權限
10 
性別
男 
註冊時間
2016-3-22 
最後登錄
2022-7-19 
4#
發表於 2016-3-24 12:00 | 只看該作者
回復 2# stillfish00
發文三分鐘禁止修改Orz

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

變成這樣...

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

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

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
5#
發表於 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

Haven

帖子
6 
主題
1 
精華
0 
積分
15 
點名
0  
作業系統
Win2000 
軟體版本
Excel2010 
閱讀權限
10 
性別
男 
註冊時間
2016-3-22 
最後登錄
2022-7-19 
6#
發表於 2016-4-5 13:17 | 只看該作者
感謝大大指導...前陣子工作的地方沒辦法上網...
一直沒回應很抱歉...囧

TOP

Haven

帖子
6 
主題
1 
精華
0 
積分
15 
點名
0  
作業系統
Win2000 
軟體版本
Excel2010 
閱讀權限
10 
性別
男 
註冊時間
2016-3-22 
最後登錄
2022-7-19 
7#
發表於 2016-4-12 08:36 | 只看該作者
不好意思 多次麻煩...想再次詢問...我用大大的編碼做整理
最近發現，似乎有跳名次的狀況出現
下圖左邊是大大的編碼所排出的前十大NG設備，右邊是樞紐分析表排出的十大NG設備

最右邊的是設備的排名...
  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.抱歉實際設備名稱因保密條約得避免公開...造成不便很抱歉...

TOP

Haven

帖子
6 
主題
1 
精華
0 
積分
15 
點名
0  
作業系統
Win2000 
軟體版本
Excel2010 
閱讀權限
10 
性別
男 
註冊時間
2016-3-22 
最後登錄
2022-7-19 
8#
發表於 2016-4-13 17:08 | 只看該作者
已解決...感謝QQ

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
9#
發表於 2024-1-12 16:40 | 只看該作者
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典中的字典,學習方案如下,請各位前輩指教
執行前:


執行結果:


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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 真正的愛心，是照顧好自己的這顆心。
返回列表 上一主題