12
返回列表 上一主題 發帖

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的儲存格??
擷取.JPG
2019-8-9 16:33
  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)
收藏 分享

准提部林

帖子
2728 
主題
10 
精華
0 
積分
2784 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2023-11-28 
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

准提部林

帖子
2728 
主題
10 
精華
0 
積分
2784 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2023-11-28 
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

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

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

TOP

        靜思自在 : 脾氣嘴巴不好，心地再好也不能算是好人。
12
返回列表 上一主題