在单元格区域里有连续的数字，就显示

dsmch

这样？
新建 Microsoft Office Excel 工作表.rar (9.19 KB, 下载次数: 17)

2011-4-20 16:29 上传

点击文件名下载附件

xiaoman84

谢谢楼上大大，就是这样了

悟空师弟

=IFERROR(SUBSTITUTE(MID(TEXT(SUM(LARGE(A1:F1,ROW($1:$6))*10^(ROW($1:$6)*2-2)),REPT(" 00",6)),MATCH(1=1,SMALL(A1:F1,ROW($2:$6))-SMALL(A1:F1,ROW($1:$5))=1,)*3-2,SUM(N(SMALL(A1:F1,ROW($2:$6))-SMALL(A1:F1,ROW($1:$5))=1))*3+3)," 0"," "),"")

[ 本帖最后由 悟空师弟 于 2011-4-20 17:10 编辑 ]

悟空师弟

晕，这特殊情况还真不少，11楼结果也好似不对……
23、8、16、26、7、9
排成
8、9、7、8
这样？

Zamyi

Sub Macro1()
Dim a()
n = [a65536].End(3).Row
r = Range("a1:f" & n)
ReDim a(1 To n, 1 To 1)
For i = 1 To n
  For j = 1 To 5
    If r(i, j + 1) - r(i, j) = 1 Then a(i, 1) = a(i, 1) & " " & r(i, j) & " " & r(i, j + 1)
  Next
Next
[g1].Resize(n) = a
End Sub

[ 本帖最后由 Zamyi 于 2011-4-20 17:26 编辑 ]

悟空师弟

汗一个，函数方法竟然跑到VBA版块……
都是从最新帖里看到后点击进入的，没注意到是VBA问题。
如果显示最新帖的标题前加个版块名称就方便看了，看到VBA的可以很轻松地飘过……

xiaoman84

请问一下，我把数据源移了一点儿位置，但是有些数据就显示不出来了，附件里红色的字体，是应该有，而没有出来的部分。
哪部分代码不对了？

Moneky

1. '   ┏─────────────────┓
   
2. '   │           Power by Moneky        │
   
3. '   │           eersoft@163.com        │
   
4. '   ┗─────────────────┛
   
5. Sub doWork()
   
6.     Dim num As New Dictionary
   
7.     Dim arr, bakrr
   
8.     Dim r_Count As Long
   
9.     Dim i As Long, j As Long, k As Long, n1 As Long, n2 As Long
   
10.     Dim Rng As Range
    
11.    
    
12.     Application.ScreenUpdating = False
    
13.     '预处理
    
14.     r_Count = [c65536].End(xlUp).Row    '取得行数
    
15.     bakrr = Range("c3:h" & CStr(r_Count))   '备份数据区域,因为马上要排序
    
16.     Set sht = Sheets(1)                 '设定工作表
    
17.     For i = 1 To r_Count                '数据区域排序
    
18.         Set Rng = Range("c" & CStr(i) & ":h" & CStr(i))
    
19.         SortRng Rng
    
20.     Next
    
21.     arr = Range("c3:h" & CStr(r_Count)) '保存排序后的数据区域
    
22.     Range("c3:h" & CStr(r_Count)) = bakrr   '还原数据区域
    
23.     '正式处理开始
    
24.     For i = 3 To r_Count   '按行循环处理
    
25.         num.RemoveAll
    
26.         For j = 1 To 5  '只需处理每行前5个（个数-2）
    
27.             n1 = arr(i - 2, j) '第一个和第二个数（相邻）
    
28.             n2 = arr(i - 2, j + 1)
    
29.             If n2 - n1 = 1 Then
    
30.                 If Not num.Exists(n1) Then num.Add n1, ""
    
31.                 If Not num.Exists(n2) Then num.Add n2, ""
    
32.             End If
    
33.         Next
    
34.         Range("i" & CStr(i) & ":n" & CStr(i)) = num.Keys
    
35.     Next
    
36.    
    
37.     '下面是扫尾工作
    
38.     '去掉#N/A
    
39.     Range("i" & CStr(1) & ":n" & CStr(r_Count)).Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
    
40.         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    
41.         ReplaceFormat:=False
    
42.     '排序
    
43.     For i = 1 To r_Count
    
44.         Set Rng = Range("i" & CStr(i) & ":n" & CStr(i))
    
45.         SortRng Rng
    
46.     Next
    
47.     Application.ScreenUpdating = True
    
48.     '善后
    
49.     Set num = Nothing
    
50.     Set sht = Nothing
    
51.     Set Rng = Nothing
    
52.     Set arr = Nothing
    
53.     Set bakrr = Nothing
    
54.    
    
55.     MsgBox "处理完成！", vbInformation + vbOKOnly, "Eersoft-提示"
    
56. End Sub
    
57. Sub SortRng(Rng As Range)
    
58.         Rng.Sort Key1:=Rng.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, _
    
59.         OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, SortMethod _
    
60.         :=xlPinYin, DataOption1:=xlSortNormal
    
61. End Sub
    

复制代码

xiaoman84

11楼大大，我找不出哪儿错了

xiaoman84

谢谢，楼上两位。弱弱的问一句，为什么加了个+2就解决了呢