請問EXCEL VBA是否有辦法做到十大項目的細項功能...? - Excel程式區

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

1^# 跳轉到 »

發表於 2016-3-23 10:34 | 顯示全部帖子

回復 1# Haven

複製代碼

表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

2^#

發表於 2016-3-24 17:27 | 顯示全部帖子

回復 4# Haven

Sub Test()
Dim ar, dMachines As Object, dTemp As Object
ar = [a1].CurrentRegion.Value
Set dMachines = CreateObject("scripting.dictionary")
Set dBelong = CreateObject("scripting.dictionary")
For i = 2 To UBound(ar)
If Not dMachines.exists(ar(i, 3)) Then
Set dTemp = CreateObject("scripting.dictionary")
dMachines.Add ar(i, 3), dTemp
Else
Set dTemp = dMachines(ar(i, 3))
End If
dTemp(ar(i, 2)) = dTemp(ar(i, 2)) + 1
dBelong(ar(i, 3)) = ar(i, 1)
Next
Dim s As String, cnt As Integer
For Each x In dMachines.keys
s = "": cnt = 0
Set dTemp = dMachines(x)
For Each y In dTemp.keys
s = s & IIf(Len(s) = 0, "", ",") & y & "*" & dTemp(y)
cnt = cnt + dTemp(y)
Next
dMachines(x) = Array(x, s, dBelong(x) & "設備異常", cnt)
Next
'Output
With Sheets.Add
cnt = dMachines.Count
With .[a1]
.Cells(1, 2).Resize(cnt, 4) = Application.Transpose(Application.Transpose(dMachines.items))
.Resize(cnt, 5).Sort .Cells(1, 5), xlDescending ', , .Cells(1, 2), xlAscending
.Cells(1, 5).EntireColumn.ClearContents
If cnt > 10 Then
.Offset(10).Resize(cnt - 10, 4).ClearContents
cnt = 10
End If
.Value = Format(Now(), "m月d日")
.Resize(cnt).Merge
End With
End With
End Sub

複製代碼

表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

靜思自在 : 【時間成就一切】時間可以造就人格，可以成就事業，也可以儲積功德。