查看: 4045|回复: 9
用VBA如何提取重复数据，并排序，谢谢！
阅读权限20
在线时间 小时
如题，见附件.谢谢！
[ 本帖最后由 tianyaguke 于
00:10 编辑 ]
00:09 上传
点击文件名下载附件
1.68 KB, 下载次数: 192
阅读权限90
在线时间 小时
本例，我认为用函数就可以了，在C列用一个countif,然后按C列排序，结果全部就出来了
另外说明一下，如果数据量大，那么在使用countif前，事先对B列进行排序，并且估计最大的重复数量，比如最多重复可能有20个，则在标题前插入11行，此时第一个数据在第13行，C13的公式是=COUNTIF(B1:B24,B13)，填充后，C列去公式，删除前11行空白行，这样做的目的：如果=COUNTIF(B:B,B13)，且B列很多，将会是很慢了。
阅读权限50
在线时间 小时
看看是不是这种效果？
12:31 上传
点击文件名下载附件
11.17 KB, 下载次数: 255
阅读权限95
在线时间 小时
Sub GetData()
& & Dim Arr, k%
& & Dim Dic As Object, Itm
& & Arr = Sheets(1).[A1].CurrentRegion
& & Set Dic = CreateObject(&Scripting.Dictionary&)
& & For k = 2 To UBound(Arr)
& && &&&Dic(Arr(k, 2)) = Dic(Arr(k, 2)) + 1
& & Next
& & For k = 2 To UBound(Arr)
& && &&&If Dic(Arr(k, 2)) = 1 Then Arr(k, 1) = &&
& & Next
& & Dic.RemoveAll
& & With Sheets(3).[A1].Resize(k - 1, 2)
& && &&&.Value = Arr
& && &&&.Sort key1:=Sheets(3).[B1], order1:=1, key2:=Sheets(3).[A1], order2:=1, header:=xlYes
& && &&&.SpecialCells(4).Delete 3
& & End With
End Sub
复制代码
阅读权限20
在线时间 小时
& & & & & & & &
二楼的朋友，这道题是可以不用VBA做出来，不过我是觉得比较麻烦，先要把数据复制到SHEET3，排序，再插入一列函数得出每个型号在当列中的次数，再筛选出有重复的项，如果数据较多的话，用函数会很卡。
三楼的朋友，可能是我说的不是很清楚。我要的结果是：
001& & & & nih01
002& & & & nih01
002& & & & nih03
003& & & & nih03
004& & & & nih03
005& & & & nih03
型号一样的排在一起，并且按单号从小到大排列。型号不重复的就不要算在这里面了。
我自己做了一个VBA程序，也是要增加辅助列来实现，实现要求后，然后再删除辅助列。为了美观，我还要加上去除C列的代码，而里面那些没有筛选出来的内容却清除不了。不知道能不能不增加辅助列实现。还有一个问题，如何用VBA复制筛选出来的数据，我复制粘贴出来的带了很多的# N/A
[ 本帖最后由 tianyaguke 于
03:49 编辑 ]
阅读权限20
在线时间 小时
谢谢alzeng，这正是我想要的结果。不过我看了大半天勉强能看懂前面四五句代码，其他的都无法理解，能对每一句注释下吗，我真的好想学这个，但无法理解啊，谢谢！
阅读权限10
在线时间 小时
坛子里的高手太多了，学习了。
阅读权限10
在线时间 小时
请问aleng高手，如果只想把重复数据提取要保留哪段code呢？谢谢指教！
阅读权限10
在线时间 小时
不好意思，请问请问alzeng高手，如果只想把重复数据提取要保留哪段code呢？谢谢指教！
阅读权限95
在线时间 小时
leon6678 发表于
不好意思，请问请问alzeng高手，如果只想把重复数据提取要保留哪段code呢？谢谢指教！
什么意思呀，能把结果模拟一下吗。。。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师收藏一段VBA脚本【根据Excel的sheet名排序】 - 学不可以已 - ITeye技术网站
博客分类：
刚刚遇到一个问题，程序处理完Excel之后，发现sheet的序号排序乱了，问过谷老师，拿到一个答案，贴出这段脚本，
做为备份。
Sub Sorting()
Dim sCount As Integer, i As Integer, j As Integer
Application.ScreenUpdating = False
sCount = Worksheets.Count
If sCount = 1 Then Exit Sub
For i = 1 To sCount - 1
For j = i + 1 To sCount
If Worksheets(j).Name & Worksheets(i).Name Then
Worksheets(j).Move before:=Worksheets(i)
Sub SortSheet()
Dim WsCount As Integer
Dim WsArray() As String
Dim Ws As Worksheet
On Error Resume Next
WsCount = ActiveWorkbook.Worksheets.Count
ReDim WsArray(1 To WsCount)
If ActiveWorkbook.ProtectStructure Then
MsgBox ActiveWorkbook.Name & " 被保护，不能进行排序，请解除保护后排序", _
vbCritical, "不能排序工作表"
For Each Ws In ActiveWorkbook.Worksheets
WsArray(t) = Ws.Name
'对数组进行排序
For i = 1 To UBound(WsArray) - 1
For j = i + 1 To UBound(WsArray)
If WsArray(i) & WsArray(j) Then
t = WsArray(i)
WsArray(i) = WsArray(j)
WsArray(j) = t
'利用Move方法以及Sheets(i)移动工作表，按指定的顺序排列
For i = 1 To WsCount
Worksheets(WsArray(i)).Move before:=Sheets(i)
使用方法：
在sheet底脚右击打开“查看代码”-》在代码区域cp以上脚本-》菜单“运行”(或者F5)，保存即可！
浏览: 234725 次
来自: 北京
cast(1234.56 as decimal(10,2))
solrcloud5.2.1+zookeeper一部精通课程观 ...
这里的：《javadoc设置》，讲解的很不错。
dotjar 写道只消重新开启Terminal可source
关于el表达式里面fn的用法，下面这个文章讲解的非常全面和详细 ...Excel VBA如何按单元格颜色排序_百度知道
Excel VBA如何按单元格颜色排序
提问者采纳
G.SortFields.SortMethod = xlPinYin
xlSortOnCellColor, 。只是使用前要进行设置.Color = RGB(83, 141, xlSortNormal).MatchCase = False
.SortOnValue, B &#39.Clear
ActiveSheet.SortF定义颜色值　此例为深蓝色R = 83G = 141B = 213
ActiveSheet.Sort.Header = xlGuess
，没有菜单上的按钮那么好用:B&B.Add(range(ranges), 213)
With ActiveSheet.Apply
End WithEnd Sub张志晨.SetRange range(ranges)
：通过没测试了; &#39Sub 排序()Dim ranges As Stringranges = &quot, xlAscending.Orientation = xlTopToBottom根据需要定义列　此为B列Dim R.Sort
先谢谢你!你的回答使我看到了希望，经测试，还有一点问题，在运行到.Apply，出现一个对话框：运行时错误'1004':排序引用无效。请确保它在所要排序的数据内，并且第一个“排序依据”框不相同且不为空。另外，麻烦你在此基础上，增加两列两列的循环句子，再给你加分。 For a = 1 To 26 Step 2 Columns(a).Resize(, 2).SelectNext
我的EXCEL是2010版本的，是通过测试的。你的意思是不是想同时选中多个不一定相连的列？..................................................Sub 排序()Dim ranges As Stringranges = &B:B& '根据需要定义列　此为B列Dim R, G, B '定义颜色值　此例为深蓝色R = 83G = 141B = 213
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add(Range(ranges), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(83, 141, 213)
With ActiveSheet.Sort
.SetRange Range(ranges)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
End WithDim s As StringDim letter As Stringletter = &ABCDEFGHIJKLMNOPQRSTUVWXYZ&
For a = 1 To 26 Step 2
s = s & Mid(letter, a, 1) & &:& & Mid(letter, a + 1, 1) & &,&
s = Mid(s, 1, Len(s) - 1)
Range(s).Select'Columns(a).Resize(, 2).SelectEnd Sub
要求：选中A、B两列，在自定义排序中，主要关键字选B列，排序依据：选单元格颜色，次序：选红色。我的主要目的：用宏做一个两列两列的选择，以单元格为红色的排序循环，例如：第一个选择A、B列，第二个选择C、D列，以此类推，一直循环到Y、Z列结束。见我的提问：如何修改ranges = &B:B&为A、B两列？
fors 80End SubFunction fors(clm As Integer)Dim s As String, t As StringDim a As IntegerDim letter As Stringletter = &ABCDEFGHIJKLMNOPQRSTUVWXYZ&
For a = 1 To clm Step 2
Dim i As Integer, j As Integer
i = a Mod 26: If i = 0 Then i = 26
j = Int(a / 26)
If j = 0 Then
s = Mid(letter, i, 1) & &:& & Mid(letter, i + 1, 1)
t = Mid(letter, i + 1, 1) & &:& & Mid(letter, i + 1, 1)
ElseIf j & 0 Then
s = Mid(letter, j, 1) & Mid(letter, i, 1) & &:& & Mid(letter, j, 1) & Mid(letter, i + 1, 1)
t = Mid(letter, j, 1) & Mid(letter, i + 1, 1) & &:& & Mid(letter, j, 1) & Mid(letter, i + 1, 1)
Range(s).Select
Call 排序(s, t)
NextEnd FunctionFunction 排序(ranges As String, ranget As String)Dim R, G, B '定义颜色值　此例为深蓝色R = 255G = 0B = 0
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add(Range(ranget), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(R, G, B)
With ActiveSheet.Sort
.SetRange Range(ranges)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
End WithEnd Function张志晨：终结版！！
提问者评价
谢谢你的正确答案!加送30分。
其他类似问题
为您推荐：
excel的相关知识
等待您来回答
下载知道APP
随时随地咨询
出门在外也不愁查看: 612|回复: 6
关于多条件不重复统计并排序，恳请大侠的帮助
阅读权限10
在线时间 小时
& & & & & & & &
总共有三列，第一列明确只有四项（甲、乙、丙、丁），第二列和第三列的数据总项会随不同的录入数据发生变化。但规律是：第一列的每一个“名称”有可能包含第二列的多个“类别”，第二列的每一个“类别”有可能包含第三项中的多个“描述”。
现在需要从左到右的优先级进行排序，同时对三列都完全相同的项进行个数统计。因为第二、三列数据量算是未知的，我本打算用字典做，但是这种多条件，貌似需要多次统计的方法着实不会，恳请大侠们不吝援手。
多条件不重复统计并排序.jpg (92.26 KB, 下载次数: 0)
多条件不重复统计并排序
08:41 上传
(2.53 KB, 下载次数: 15)
08:41 上传
点击文件名下载附件
多条件不重复统计并排序
阅读权限90
在线时间 小时
多Key数组排序(分类、统计、重复处理)-自定义函数
阅读权限95
在线时间 小时
Sub test11()
& & Set d = CreateObject(&scripting.dictionary&)
& & Application.ScreenUpdating = False
& & arr = Sheets(2).[a1].CurrentRegion
& & For j = 2 To Sheets(2).Cells(Rows.Count, 1).End(3).Row
& && &&&d(arr(j, 1) & &-& & arr(j, 2) & &-& & arr(j, 3)) = 1 + d(arr(j, 1) & &-& & arr(j, 2) & &-& & arr(j, 3))
& & Next j
& & arr1 = d.keys
& & arr2 = d.items
& & Sheets(3).Select
& & Sheets(3).Cells.ClearContents
& & Sheets(3).Cells(1, 1).Resize(d.Count) = WorksheetFunction.Transpose(arr1)
& & Sheets(3).Cells(1, 4).Resize(d.Count) = WorksheetFunction.Transpose(arr2)
& & 'Cells.Select
'& & Cells.Sort Key1:=Range(&A1&), Order1:=xlAscending
& & Cells.Select
& & Selection.Sort Key1:=Range(&A1&), Order1:=xlAscending, Header:=xlGuess, _
& && &&&OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
& && &&&:=xlPinYin, DataOption1:=xlSortNormal
& & arr4 = Sheets(3).UsedRange
& & Sheets(3).Cells.ClearContents
& & Sheets(3).Cells(1, 1) = &名称&
& & Sheets(3).Cells(1, 2) = &分类&
& & Sheets(3).Cells(1, 3) = &描述&
& & Sheets(3).Cells(1, 4) = &数量&
& & For j = 1 To d.Count
& && &&&If Left(arr4(j, 1), 1) = &甲& Then
& && && && &Sheets(3).Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(1, 3) = Split(arr4(j, 1), &-&)
& && && && &Sheets(3).Cells(Rows.Count, 4).End(3).Offset(1, 0) = arr4(j, 4)
& && &&&End If
& & Next j
& & For j = 1 To d.Count
& && &&&If Left(arr4(j, 1), 1) = &乙& Then
& && && && &Sheets(3).Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(1, 3) = Split(arr4(j, 1), &-&)
& && && && &Sheets(3).Cells(Rows.Count, 4).End(3).Offset(1, 0) = arr4(j, 4)
& && &&&End If
& & Next j
& & For j = 1 To d.Count
& && &&&If Left(arr4(j, 1), 1) = &丙& Then
& && && && &Sheets(3).Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(1, 3) = Split(arr4(j, 1), &-&)
& && && && &Sheets(3).Cells(Rows.Count, 4).End(3).Offset(1, 0) = arr4(j, 4)
& && &&&End If
& & Next j
& & For j = 1 To d.Count
& && &&&If Left(arr4(j, 1), 1) = &丁& Then
& && && && &Sheets(3).Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(1, 3) = Split(arr4(j, 1), &-&)
& && && && &Sheets(3).Cells(Rows.Count, 4).End(3).Offset(1, 0) = arr4(j, 4)
& && &&&End If
& & Next j
& & Application.ScreenUpdating = True
合并单元格没有做，自己合并吧
原始数据再表二里，生成结果在表三
阅读权限95
在线时间 小时
详见附件内容，，，，
10:18 上传
点击文件名下载附件
13.53 KB, 下载次数: 7
阅读权限10
在线时间 小时
我只能对楼上两位大侠表达犹如长江之水的佩服！
阅读权限70
在线时间 小时
Sub tt()
& & arr = [a1].CurrentRegion
& & Set d = CreateObject(&scripting.dictionary&)
& & ReDim brr(1 To UBound(arr), 1 To 4)
& & For i = 2 To UBound(arr)
& && &&&x = arr(i, 1) & &,& & arr(i, 2) & &,& & arr(i, 3)
& && &&&d(x) = d(x) + 1
& & Next
& & dk = d.keys: dt = d.items
& & ReDim brr(1 To d.Count, 1 To 4)
& & For i = 0 To UBound(dk)
& && &&&xrr = Split(dk(i), &,&)
& && &&&brr(i + 1, 1) = xrr(0)
& && &&&brr(i + 1, 2) = xrr(1)
& && &&&brr(i + 1, 3) = xrr(2)
& && &&&brr(i + 1, 4) = dt(i)
& & Next
& &
& & Range(&L:O&).Delete
& & [L1].Resize(1, 4) = Array(&名称&, &分类&, &描述&, &个数&)
& & [L1].Resize(i + 1, 4).Borders.LineStyle = 1
& & [L1].Resize(i + 1, 4).HorizontalAlignment = xlCenter
& & With [L2]
& && &&&.Resize(i, 4) = brr
& && &&&.Resize(i, 4).Sort key1:=.Offset(0, 0), OrderCustom:=12, key2:=.Offset(0, 1), key3:=.Offset(0, 2)& & 'OrderCustom:=12表示按固定序列12排序（甲、乙、丙、丁。。。。）
& && &&&xr = .Row: xc = .Column
& && &&&Call Mergerng(xr, xc)
& && &&&Call Mergerng(xr, xc + 1)
& & End With
End Sub
Sub Mergerng(xr, xc)& &'第xc列，从Xr行开始合并单元格
& && &Dim IntRow As Integer
& && &Dim i As Integer
& && &Application.DisplayAlerts = False
& && &r = Cells(65536, xc).End(3).Row
& && &s1 = xr
& && &For i = xr To r
& && && && &If Cells(i + 1, xc) && Cells(i, xc) Then
& && && && && & Range(Cells(s1, xc), Cells(i, xc)).Merge
& && && && && & s1 = i + 1
& && && && &End If
& && &Next
& && &Application.DisplayAlerts = True
&&End Sub
阅读权限70
在线时间 小时
请看附件。
11:06 上传
点击文件名下载附件
14.41 KB, 下载次数: 20
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师}