返回列表 上一主題 發帖

VBA 計算數據出現次數並排序

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2019-8-9 16:32 | 只看該作者

VBA 計算數據出現次數並排序

本帖最後由 s13030029 於 2019-8-9 16:34 編輯

Q1：請問要如何不顯示或計算空白的儲存格??
Q2：請問要如何不顯示次數小於1的儲存格??
  1. Sub 按出現次數排序()
  2.     Dim d As Object
  3.     Dim Arr
  4.     Dim i As Integer, j As Integer
  5.     Application.ScreenUpdating = False
  6.     Range("A15:B30").Clear
  7.     '提取不重複值併計算出現次數
  8.     Set d = CreateObject("Scripting.Dictionary")
  9.     Arr = Range("A2:H6")
  10.     For i = 1 To UBound(Arr, 1) '計算陣列大小(列)
  11.         For j = 1 To UBound(Arr, 2) '計算陣列大小(欄)
  12.             If Not d.Exists(Arr(i, j)) Then
  13.                 d.Add Arr(i, j), 1
  14.             Else
  15.                 d.Item(Arr(i, j)) = d.Item(Arr(i, j)) + 1
  16.             End If
  17.         Next
  18.     Next
  19.    
  20.     '輸出並排序
  21.     Range("A15").Resize(d.Count) = Application.Transpose(d.keys)
  22.     Range("B15").Resize(d.Count) = Application.Transpose(d.items)
  23.     Range("A15:B15").Resize(d.Count).Sort key1:=Range("B14"), Order1:=xlDescending
  24.    
  25.     Set d = Nothing
  26.     Application.ScreenUpdating = True
  27. End Sub
複製代碼
test.rar (20.2 KB)
收藏 分享

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
2#
發表於 2019-8-10 10:13 | 只看該作者
Sub 按出現次數排序()
Dim Arr, A, xD, Brr(1 To 20000, 1 To 2), N&
Range("A15:B30").Clear
Arr = Range("A2:H6")
Set xD = CreateObject("Scripting.Dictionary")
For Each A In Arr
    If A = "" Then GoTo 101
    xD(A) = xD(A) + 1
    If xD(A) = 2 Then N = N + 1:  xD(A & "S") = N:  Brr(N, 1) = A
    If xD(A) > 1 Then Brr(xD(A & "S"), 2) = xD(A)
101: Next
With [A15:B15].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
End With
End Sub


==========================================

TOP

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
3#
發表於 2019-8-12 13:32 | 只看該作者
回復 2# 准提部林
那如果說我的數據可能沒有全部輸入完，但是每筆出現的次數都只有一次
這段程式碼就會出現錯誤，這要怎麼改?
With [G1:H1].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
End With

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
4#
發表於 2019-8-12 14:23 | 只看該作者
回復 3# s13030029

   IF N=0 THEN EXIT SUB '加這一行
   With [A15:B15].Resize(N)
     .Value = Brr
     .Sort Key1:=.Item(2), Order1:=xlDescending, _
           Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
   End With

TOP

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
5#
發表於 2019-8-12 15:28 | 只看該作者
回復 4# 准提部林

原來如此~謝謝准大~~

TOP

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
6#
發表於 2019-8-14 10:34 | 只看該作者
本帖最後由 s13030029 於 2019-8-14 10:44 編輯

回復 2# 准提部林
准大~
我想再請問一下，如果要再找出最大值和最小值，並用.Interior.Color 標記成紅色的話，要怎麼改???
(出現次數等於1的部分可能還是要顯示出來)
test.rar (27.38 KB)
  1. Sub 按出現次數排序()
  2.     Application.ScreenUpdating = False
  3.     Dim Arr, a, xD, Brr(1 To 20000, 1 To 2), N&
  4.     ThisWorkbook.Sheets("量測").Range("H2:I" & Range("H" & Rows.Count).End(xlDown).Row).Clear
  5.     Arr = Range("B2:F31")
  6.     Set xD = CreateObject("Scripting.Dictionary")
  7.     If ThisWorkbook.Sheets("量測").[B2] = "" Then Exit Sub
  8.     For Each a In Arr
  9.         If a = "" Then GoTo 101
  10.         xD(a) = xD(a) + 1
  11.         If xD(a) = 1 Then N = N + 1:  xD(a & "S") = N:  Brr(N, 1) = a
  12.         If xD(a) > 1 Then Brr(xD(a & "S"), 2) = xD(a)
  13. 101:     Next
  14.     If N = 0 Then Exit Sub
  15.     With ThisWorkbook.Sheets("量測").[H2:I2].Resize(N)
  16.          .Value = Brr
  17.          .Sort Key1:=.Item(2), Order1:=xlDescending, _
  18.                Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
  19.     End With

  21.     With ThisWorkbook.Sheets("量測").Range("H1:I" & Range("H" & Rows.Count).End(xlUp).Row)
  22.          .NumberFormatLocal = "0.00_ "
  23.         .HorizontalAlignment = xlCenter
  24.         .VerticalAlignment = xlCenter
  25.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  26.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  27.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  28.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  29.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  30.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  31.     End With
  32.     With ThisWorkbook.Sheets("量測").Range("I1:I11")
  33.         .NumberFormatLocal = "0"
  34.     End With
  35.     For x = 2 To 6
  36.     For Y = 2 To 31
  37.         Cells(Y, x).Interior.Color = xlNone
  38.         If Cells(Y, x).Value = Cells(2, "H").Value And Cells(2, "H") <> "" Then
  39.             Cells(Y, x).Interior.Color = RGB(252, 216, 162)
  40.             Cells(2, "H").Interior.Color = RGB(252, 216, 162)
  41.         End If
  42.         If Cells(Y, x).Value = Cells(3, "H").Value And Cells(3, "H") <> "" Then
  43.             Cells(Y, x).Interior.Color = RGB(144, 248, 169)
  44.             Cells(3, "H").Interior.Color = RGB(144, 248, 169)
  45.         End If
  46.         If Cells(Y, x).Value = Cells(4, "H").Value And Cells(4, "H") <> "" Then
  47.             Cells(Y, x).Interior.Color = RGB(170, 250, 252)
  48.             Cells(4, "H").Interior.Color = RGB(170, 250, 252)
  49.         End If
  50.     Next Y
  51.     Next x
  52.     Application.ScreenUpdating = True
  53. End Sub
  54. '=================================
  55. Sub 清除()
  56.     ThisWorkbook.Sheets("量測").Range("B2:F31").ClearContents
  57.     With ThisWorkbook.Sheets("量測").Range("B2:F31")
  58.         .NumberFormatLocal = "0.00_ "
  59.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  60.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  61.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  62.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  63.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  64.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  65.         .Interior.Color = xlNone
  66.     End With
  67.     Range("B2").Select
  68. End Sub
複製代碼

TOP

hcm19522

帖子
1387 
主題
4 
精華
0 
積分
1397 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2024-11-22 

熱烈參與勳章
7#
發表於 2019-8-14 18:49 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/588109997
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

s13030029
　暱稱: 伊恩

中學生Rank: 2

帖子
97 
主題
33 
精華
0 
積分
129 
點名
0  
作業系統
Win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
男 
註冊時間
2019-5-7 
最後登錄
2022-8-25 
8#
發表於 2019-8-15 08:38 | 只看該作者
這是我做出來的結果給大家參考~~~
  1. Sub 按出現次數排序()
  2.     Application.ScreenUpdating = False
  3.     Dim Arr, a, xD, Brr(1 To 20000, 1 To 2), N&
  4.     ThisWorkbook.Sheets("量測").Range("H2:I" & Range("H" & Rows.Count).End(xlDown).Row).Clear
  5.     Arr = Range("B2:F31")
  6.     Set xD = CreateObject("Scripting.Dictionary")
  7.     If ThisWorkbook.Sheets("量測").[B2] = "" Then Exit Sub
  8.     For Each a In Arr
  9.         If a = "" Then GoTo 101
  10.         xD(a) = xD(a) + 1
  11.         If xD(a) = 2 Then N = N + 1:  xD(a & "S") = N:  Brr(N, 1) = a
  12.         If xD(a) > 1 Then Brr(xD(a & "S"), 2) = xD(a)
  13. 101:     Next
  14.     '排序
  15.     If N = 0 Then Exit Sub
  16.     With ThisWorkbook.Sheets("量測").[H2:I2].Resize(N)
  17.          .Value = Brr
  18.          .Sort Key1:=.Item(2), Order1:=xlDescending, _
  19.                Key2:=.Item(1), Order2:=xlDescending, Header:=xlNo
  20.     End With
  21.     '儲存格置中、格線、小數點
  22.     With ThisWorkbook.Sheets("量測").Range("H1:I" & Range("H" & Rows.Count).End(xlUp).Row)
  23.          .NumberFormatLocal = "0.00_ "
  24.         .HorizontalAlignment = xlCenter
  25.         .VerticalAlignment = xlCenter
  26.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  27.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  28.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  29.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  30.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  31.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  32.     End With
  33.     With ThisWorkbook.Sheets("量測").Range("I1:I11")
  34.         .NumberFormatLocal = "0"
  35.     End With
  36.     '找最大值、最小值
  37.     With ThisWorkbook.Sheets("量測").Range("K1:L2")
  38.          [k1].Value = "最大值": [L1].Value = "最小值"
  39.          Range("K1:L1").Font.Bold = True
  40.          Range("K1:L1").Name = "新細明體"
  41.         .Font.Size = 12
  42.         Range("K1:L1").Interior.Color = RGB(217, 226, 243)
  43.         .HorizontalAlignment = xlCenter
  44.         .VerticalAlignment = xlCenter
  45.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  46.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  47.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  48.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  49.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  50.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  51.     End With
  52.     [k2] = Application.Max(Arr)
  53.     [L2] = Application.Min(Arr)
  54.     '找對應的值，並填滿顏色
  55.     For x = 2 To 6
  56.     For Y = 2 To 31
  57.         Cells(Y, x).Interior.Color = xlNone
  58.         If Cells(Y, x).Value = [H2].Value And [H2] <> "" Then
  59.             Cells(Y, x).Interior.Color = RGB(252, 216, 162)
  60.             [H2].Interior.Color = RGB(252, 216, 162)
  61.         End If
  62.         If Cells(Y, x).Value = [H3].Value And [H3] <> "" Then
  63.             Cells(Y, x).Interior.Color = RGB(144, 248, 169)
  64.             [H3].Interior.Color = RGB(144, 248, 169)
  65.         End If
  66.         If Cells(Y, x).Value = [H4].Value And [H4] <> "" Then
  67.             Cells(Y, x).Interior.Color = RGB(170, 250, 252)
  68.             [H4].Interior.Color = RGB(170, 250, 252)
  69.         End If
  70.         If Cells(Y, x).Value = [k2].Value Then
  71.             Cells(Y, x).Font.Color = RGB(0, 0, 255)
  72.             [k2].Font.Color = RGB(0, 0, 255)
  73.             Cells(Y, x).Font.Bold = True
  74.         End If
  75.         If Cells(Y, x).Value = [L2].Value Then
  76.             Cells(Y, x).Font.Color = RGB(255, 0, 0)
  77.             [L2].Font.Color = RGB(255, 0, 0)
  78.             Cells(Y, x).Font.Bold = True
  79.         End If
  80.     Next Y
  81.     Next x
  82.     '設定欄寬
  83.     Columns("A:L").ColumnWidth = 8
  84.     Columns("G").ColumnWidth = 3
  85.     Columns("J").ColumnWidth = 3
  86. End Sub
  87. '=================================
  88. Sub 清除()
  89.     ThisWorkbook.Sheets("量測").Range("B2:F31").ClearContents
  90.     With ThisWorkbook.Sheets("量測").Range("B2:F31")
  91.         .NumberFormatLocal = "0.00_ "
  92.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  93.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  94.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  95.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  96.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  97.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  98.         .Interior.Color = xlNone
  99.         .Font.Bold = False
  100.         .Font.Color = RGB(0, 0, 0)
  101.     End With
  102.     Range("B2").Select
  103. End Sub
複製代碼

TOP

        靜思自在 : 一句溫暖的話，就像往別人身上灑香水，自己會沾到兩三滴。
返回列表 上一主題