united7878

　暱稱: 淚的小花

中學生 Rank: 2

帖子: 32
主題: 8
精華: 0
積分: 81
點名: 0
作業系統: WINDOWS 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-8-18
最後登錄: 2020-12-13

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2014-10-21 23:55 | 只看該作者

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

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

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

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

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2014-10-22 09:16 | 只看該作者

回復 1# united7878
試試看

Option Explicit
Sub Ex_進階篩選()
Dim Rng(1 To 3) As Range
'****************************************************************
Set Rng(1) = [c3:c1002] '資料庫範圍: c3要是為資料庫的欄位標頭
'****************************************************************
Set Rng(2) = [IU1] '工作表最後第2欄:進階篩選,資料複製到的儲存格
Set Rng(3) = [M4:N13] '放置重覆最多的前10名的儲存格
Rng(2).CurrentRegion = "" 'Rng(2)必需是沒有資料
Rng(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Rng(2), Unique:=True
'進階篩選不重複的資料(Unique:=True)
With Range(Rng(2), Rng(2).End(xlDown)).Offset(1)
.Offset(, 1).FormulaR1C1 = "=COUNTIF(" & Rng(1).Address(, , xlR1C1) & ",RC[-1])" '
'寫上工作表函數COUNTIF
Rng(2).CurrentRegion.Sort KEY1:=Rng(2).Range("b1"), Order1:=xlDescending, Header:=xlYes
'Rng(2).CurrentRegion(連續範圍)的由大到小的排序(Order1:=xlDescending)
Rng(3) = Rng(2).Range("A2").Resize(10, 2).Value '資料複製
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

united7878

　暱稱: 淚的小花

中學生 Rank: 2

帖子: 32
主題: 8
精華: 0
積分: 81
點名: 0
作業系統: WINDOWS 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-8-18
最後登錄: 2020-12-13

3^#

發表於 2014-10-22 19:53 | 只看該作者

感謝G大，可以用了

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

謝謝~

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2014-10-22 20:45 | 只看該作者

回復 3# united7878
[Ex_進階篩選] 可以是一般模組,或是這工作表模組上的程序(巨集)

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) '這工作表模組的預設事件程序
Application.EnableEvents = False
If Not Application.Intersect(Target, [c3:c1002]) Is Nothing Then Ex_進階篩選
Application.EnableEvents = True
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

united7878

　暱稱: 淚的小花

中學生 Rank: 2

帖子: 32
主題: 8
精華: 0
積分: 81
點名: 0
作業系統: WINDOWS 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-8-18
最後登錄: 2020-12-13

5^#

發表於 2014-10-23 21:00 | 只看該作者

回復 4# GBKEE

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

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

謝謝感恩~

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2014-10-24 06:33 | 只看該作者

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

回復 5# united7878
是必須解除C欄與IU欄或L欄M欄之資料與儲存部分欄位的鎖定.
保護工作表有許多選項,可參考VBA說明, Protect 方法.
請選擇排序,使用自動篩選

Option Explicit
Sub Ex()
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True
End Sub

複製代碼

Ex_進階篩選須修改一下

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP