Board logo

標題: [發問] 想請教有關計算重複名字排序的語法 [打印本頁]
作者: united7878    時間: 2014-10-21 23:55     標題: 想請教有關計算重複名字排序的語法

問題如下:
在C3:C1002之間有很多的名字
其中有許多是重複的

想在M4~M13內列出重覆最多的前10名

請教板上的先進貨高手不吝賜教
謝謝~:D
作者: GBKEE    時間: 2014-10-22 09:16

回復 1# united7878
試試看
  1. Option Explicit
  2. Sub Ex_進階篩選()
  3.     Dim Rng(1 To 3) As Range
  4.     '****************************************************************
  5.     Set Rng(1) = [c3:c1002]     '資料庫範圍: c3要是為資料庫的欄位標頭
  6.     '****************************************************************
  7.     Set Rng(2) = [IU1]          '工作表最後第2欄:進階篩選,資料複製到 的儲存格
  8.     Set Rng(3) = [M4:N13]       '放置重覆最多的前10名 的儲存格
  9.     Rng(2).CurrentRegion = ""   'Rng(2)必需是沒有資料
  10.    
  11.     Rng(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Rng(2), Unique:=True
  12.     '進階篩選不重複的資料(Unique:=True)
  13.    
  14.     With Range(Rng(2), Rng(2).End(xlDown)).Offset(1)
  15.         .Offset(, 1).FormulaR1C1 = "=COUNTIF(" & Rng(1).Address(, , xlR1C1) & ",RC[-1])" '
  16.         '寫上工作表函數COUNTIF
  17.         Rng(2).CurrentRegion.Sort KEY1:=Rng(2).Range("b1"), Order1:=xlDescending, Header:=xlYes
  18.         'Rng(2).CurrentRegion(連續範圍)的由大到小的排序(Order1:=xlDescending)
  19.         Rng(3) = Rng(2).Range("A2").Resize(10, 2).Value   '資料複製
  20.     End With
  21. End Sub
複製代碼
作者: united7878    時間: 2014-10-22 19:53

感謝G大，可以用了

再一次請教G大
如果儲存格M4:M13要隨著資料格C3:C1002異動而即時變動排名的話
該修改哪個部分?

謝謝~
作者: GBKEE    時間: 2014-10-22 20:45

回復 3# united7878
[Ex_進階篩選] 可以是一般模組,或是這工作表模組上的程序(巨集)
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range) '這工作表模組的預設事件程序
  3.     Application.EnableEvents = False
  4.     If Not Application.Intersect(Target, [c3:c1002]) Is Nothing Then Ex_進階篩選
  5.     Application.EnableEvents = True
  6. End Sub
複製代碼
作者: united7878    時間: 2014-10-23 21:00

回復 4# GBKEE

再請教GBKEE大師
如果在有保護工作表的狀態下
該解除C欄與IU欄或L欄M欄之資料與儲存部分欄位的鎖定嗎?

因為我在保護工作表(選取未鎖定的儲存格)狀態下無法執行巨集指令
出現錯誤碼'1004'
我後來試著解除C、IU、L、M欄的鎖定
但依然不行
一樣是'1004'
請問這有解嗎?

謝謝感恩~
作者: GBKEE    時間: 2014-10-24 06:33

本帖最後由 GBKEE 於 2014-10-24 06:55 編輯

回復 5# united7878
是必須解除C欄與IU欄或L欄M欄之資料與儲存部分欄位的鎖定.
保護工作表有許多選項,可參考VBA說明, Protect 方法.
請選擇 排序,使用自動篩選
  1. Option Explicit
  2. Sub Ex()
  3.     ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
  4.         , AllowSorting:=True, AllowFiltering:=True
  5. End Sub
複製代碼
[attach]19384[/attach]

Ex_進階篩選 須修改一下
  1. Sub Ex_進階篩選()
  2.     Dim Rng(1 To 3) As Range
  3.     '****************************************************************
  4.     Set Rng(1) = [c3:c1002]     '資料庫範圍: c3要是為資料庫的欄位標頭
  5.     '****************************************************************
  6.     Set Rng(2) = [IU:IV]          '工作表最後第2欄:進階篩選,資料複製到 的儲存格
  7.     Set Rng(3) = [M4:N13]       '放置重覆最多的前10名 的儲存格
  8.     Rng(2) = ""  'Rng(2)必需是沒有資料
  9.    
  10.     Rng(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Rng(2).Cells(1), Unique:=True
  11.     '進階篩選不重複的資料(Unique:=True)
  12.     With Rng(2)
  13.         .Sort KEY1:=Rng(2).Range("a1"), Order1:=xlDescending, Header:=xlYes
  14.         '範圍的由大到小的排序(Order1:=xlDescending)
  15.     End With
  16.     With Range(Rng(2).Cells(1), Rng(2).Cells(1).End(xlDown))
  17.         .Offset(1, 1).FormulaR1C1 = "=COUNTIF(" & Rng(1).Address(, , xlR1C1) & ",RC[-1])" '
  18.         '寫上工作表函數COUNTIF
  19.     End With
  20.     With Rng(2)
  21.         .Sort KEY1:=Rng(2).Range("b1"), Order1:=xlDescending, Header:=xlYes
  22.     End With
  23.     Rng(3) = Rng(2).Range("A2").Resize(10, 2).Value   '資料複製
  24. End Sub
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)