[發問] 想請教有關計算重複名字排序的語法

united7878

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

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

請教板上的先進貨高手不吝賜教
謝謝~:D

GBKEE

回復 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

感謝G大，可以用了

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

謝謝~

GBKEE

回復 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

回復 4# GBKEE

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

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

謝謝感恩~

GBKEE

回復 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

複製代碼

下載 (31.81 KB)

2014-10-24 06:31

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

複製代碼