|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- ' ┏─────────────────┓
- ' │ Power by Moneky │
- ' │ eersoft@163.com │
- ' ┗─────────────────┛
- Sub doWork()
- Dim num As New Dictionary
- Dim arr, bakrr
- Dim r_Count As Long
- Dim i As Long, j As Long, k As Long, n1 As Long, n2 As Long
- Dim Rng As Range
-
- Application.ScreenUpdating = False
- '预处理
- r_Count = [c65536].End(xlUp).Row '取得行数
- bakrr = Range("c3:h" & CStr(r_Count)) '备份数据区域,因为马上要排序
- Set sht = Sheets(1) '设定工作表
- For i = 1 To r_Count '数据区域排序
- Set Rng = Range("c" & CStr(i) & ":h" & CStr(i))
- SortRng Rng
- Next
- arr = Range("c3:h" & CStr(r_Count)) '保存排序后的数据区域
- Range("c3:h" & CStr(r_Count)) = bakrr '还原数据区域
- '正式处理开始
- For i = 3 To r_Count '按行循环处理
- num.RemoveAll
- For j = 1 To 5 '只需处理每行前5个(个数-2)
- n1 = arr(i - 2, j) '第一个和第二个数(相邻)
- n2 = arr(i - 2, j + 1)
- If n2 - n1 = 1 Then
- If Not num.Exists(n1) Then num.Add n1, ""
- If Not num.Exists(n2) Then num.Add n2, ""
- End If
- Next
- Range("i" & CStr(i) & ":n" & CStr(i)) = num.Keys
- Next
-
- '下面是扫尾工作
- '去掉#N/A
- Range("i" & CStr(1) & ":n" & CStr(r_Count)).Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
- SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
- ReplaceFormat:=False
- '排序
- For i = 1 To r_Count
- Set Rng = Range("i" & CStr(i) & ":n" & CStr(i))
- SortRng Rng
- Next
- Application.ScreenUpdating = True
- '善后
- Set num = Nothing
- Set sht = Nothing
- Set Rng = Nothing
- Set arr = Nothing
- Set bakrr = Nothing
-
- MsgBox "处理完成!", vbInformation + vbOKOnly, "Eersoft-提示"
- End Sub
- Sub SortRng(Rng As Range)
- Rng.Sort Key1:=Rng.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, _
- OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, SortMethod _
- :=xlPinYin, DataOption1:=xlSortNormal
- End Sub
复制代码 |
|