[开_76] 找出没出现的号码并按要求连成串

Long_III

记得我刚开始学代码时，碰到类似问题，用了两列辅助单元格等，花了好大气力，想想都有意思。此类问题用数组处理相对就简单多了，建议初学的朋友来试试。可以用各种方法，只能能实现就可以。

本题难度一般，分数1分，优秀代码者加1分。

不好意思，关于“连续”的意思没有表达清楚，我的代码是按三连续来运行的，2个连续的是单独分开的，不过“6-8,15,19-20,26-29”也可以算正确的，主要是代码的思路。建议各位朋友能2连续和3连续都可以用一种思路完成，还有里面的数据只是一个例子，如果更改数据的大小、个数等，代码也应该可以正常运行。

2月15号进行总结！谢谢大家的参与，祝大家新年快乐！

[此贴子已经被作者于2006-2-5 9:12:05编辑过]

hisome

Sub test()
'Sheet2.Range("b65536").End(xlUp).Row

Dim r
Dim temp
Dim a$
r = Application.WorksheetFunction.CountA(Range("A:a"))
Range("a1:a" & r).Copy Destination:=Cells(1, 2)
Range("b1:b" & r).Sort key1:=Cells(1, 2), order1:=xlAscending
a = ""
For i = 2 To Cells(r, 2).Value
temp = Cells(i, 2).Value - Cells(i - 1, 2).Value
If temp = 2 Then
a = a & Cells(i - 1, 2).Value + 1 & ","
ElseIf temp > 2 Then
a = a & Cells(i - 1, 2).Value + 1 & "-" & Cells(i, 2).Value - 1 & ","
End If
Next
MsgBox a
End Sub

感觉你的答案19,20，我觉得应该这样19-20，所以就没按你所说的做

asdf1001

Option Explicit

'找出中间不连续的---结果 5-12,2-4,6-8,12-23,13,15,19-21,22-24,26-29
Sub asdf1001_1()

Dim lstarr() As Variant, lstrng As Range, lstcount As Long

Set lstrng = Sheet1.Columns(1)
lstcount = Application.CountA(lstrng)

ReDim lstarr(1 To lstcount, 1 To 1)
lstarr = lstrng.Resize(lstcount).Value

Dim i As Long
Dim tmpstr As String
For i = 2 To lstcount
Select Case lstarr(i, 1) - lstarr(i - 1, 1)
Case Is > 2: tmpstr = tmpstr & lstarr(i - 1, 1) + 1 & "-" & lstarr(i, 1) - 1 & ","
Case Is > 1: tmpstr = tmpstr & lstarr(i, 1) - 1 & ","
End Select
Next i
Debug.Print Left$(tmpstr, Len(tmpstr) - 1)
End Sub

'找出自始至终未出现的---结果 6-8,15,19,20,26-29
Sub asdf1001_2()

Dim lstarr() As Variant, lstrng As Range, lstcount As Long
Dim minnum As Integer, maxnum As Integer

Set lstrng = Sheet1.Columns(1)
lstcount = Application.CountA(lstrng)
minnum = Application.Min(lstrng)
maxnum = Application.Max(lstrng)
ReDim lstarr(1 To lstcount, 1 To 1)
lstarr = lstrng.Resize(lstcount).Value

Dim i As Integer, j As Long
Dim tmpstr As String
Dim exist_flag As Boolean

For i = minnum To maxnum
exist_flag = False
For j = 1 To lstcount
If lstarr(j, 1) = i Then exist_flag = True: Exit For
Next j
If exist_flag = False Then tmpstr = tmpstr & i & ","
Next i

Dim tmparr() As String, tmp() As String

tmparr = Split(Left$(tmpstr, Len(tmpstr) - 1), ",")
tmp = tmparr

For i = LBound(tmparr) + 1 To UBound(tmparr) - 1
If (tmparr(i) - tmparr(i - 1)) * (tmparr(i + 1) - tmparr(i)) = 1 Then tmp(i) = "-"
Next

tmpstr = Join$(tmp, ",")

Do Until InStr(1, tmpstr, "-,") + InStr(1, tmpstr, ",-") + InStr(1, tmpstr, "--") = 0
tmpstr = Replace$(tmpstr, "-,", "-")
tmpstr = Replace$(tmpstr, ",-", "-")
tmpstr = Replace$(tmpstr, "--", "-")
Loop

Debug.Print tmpstr
End Sub

danielcm

以下是引用Long_III在2006-1-24 10:03:14的发言：

记得我刚开始学代码时，碰到类似问题，用了两列辅助单元格等，花了好大气力，想想都有意思。此类问题用数组处理相对就简单多了，建议初学的朋友来试试。可以用各种方法，只能能实现就可以。

Z43fyPyD.rar (9.31 KB, 下载次数: 63)

2006-1-24 15:18 上传

点击文件名下载附件
回复：（Long_III）[VBA7] 找出没出现的号码并按要求连...

代码结果与题目要求不一致 － taller

[此贴子已经被taller于2006-1-27 14:39:58编辑过]

lj1226189

Private Sub CommandButton2_Click()
Dim i, ii, m, n, j As Integer
Dim arr, arr1()

Range("A1").Select
Range("A1:A20000").Sort Key1:=Range("A9"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal

i = [a15550].End(xlUp).Row
arr = Range("a1:a" & i)

For ii = 2 To i
If arr(ii, 1) <> arr(ii - 1, 1) + 1 and arr(ii, 1) <> arr(ii - 1, 1) Then
j = j + 1
m = arr(ii, 1) - 1
n = arr(ii - 1, 1) + 1
If n = m Then
a = m
Else
a = n & "-" & m
End If
s = s & "," & a
End If

Next
If InStr(s, ",") > 0 Then
[c4] = Mid(s, 2, 100)
Else
[c4] = s
End If

End Sub

em93NYxN.rar (13.7 KB, 下载次数: 57)

2006-1-25 10:41 上传

点击文件名下载附件
完全用数组的方法！即使有重复数据也不会有影响！

[此贴子已经被作者于2006-1-25 10:42:07编辑过]

lg_cai

我来一段，排序用代码实现

Sub px()
n = [a1].End(xlDown).Row
arr = Range("a1:a" & n)
i = 1
Do
Change = False
For j = 1 To n - i
If arr(j, 1) > arr(j + 1, 1) Then
arr(j, 1) = arr(j, 1) + arr(j + 1, 1)
arr(j + 1, 1) = arr(j, 1) - arr(j + 1, 1)
arr(j, 1) = arr(j, 1) - arr(j + 1, 1)
Change = True
End If
Next j
i = i + 1
Loop Until i = n Or Not Change
s = ""
For j = 2 To n
If arr(j, 1) - arr(j - 1, 1) = 2 Then
s = IIf(s = "", s, s & ",") & arr(j, 1) - 1
ElseIf arr(j, 1) - arr(j - 1, 1) > 2 Then
s = IIf(s = "", s, s & ",") & arr(j - 1, 1) + 1 & "-" & arr(j, 1) - 1
End If
Next j
MsgBox s
End Sub

代码结果为“7-9,15,19-20,26-29”，不正确 － taller

[此贴子已经被taller于2006-1-27 14:27:21编辑过]

plxmm

Sub Plxmm()
Application.ScreenUpdating = False
Dim i&, p&, s$, ary()
Dim arr As Range
[C4].ClearContents
p = [a65536].End(xlUp).Row
Set arr = Range("a1:a" & p)
arr.Sort Key1:=arr(1, 1), Order1:=xlAscending, Header:=xlNo
s = ""
For i = 2 To p
If arr(i, 1) - arr(i - 1, 1) = 2 Then
s = IIf(s = "", s, s & ",") & arr(i, 1) - 1
ElseIf arr(i, 1) - arr(i - 1, 1) > 2 Then
s = IIf(s = "", s, s & ",") & arr(i - 1, 1) + 1 & "-" & arr(i, 1) - 1
End If
Next i
[C4] = s
End Sub

cooloaky

无须排序,无须单元格引用的纯数组处理方法

Sub myMethod()
Dim ds As Object, i, k, x, b As Long, rng, arr()

Set ds = CreateObject("scripting.dictionary")
rng = Range("a1").CurrentRegion
For i = 1 To UBound(rng, 1)
ds.Add rng(i, 1), i
Next i

x = Application.Min(rng)
For i = Application.Min(rng) To Application.Max(rng)
If Len(ds.Item(i)) = 0 Then 'missed item
k = k + 1
If i - x <> 1 Then
b = b + 1
ReDim Preserve arr(1 To b)
arr(b) = i
Else
arr(b) = Split(arr(b), "-")(0) & "-" & i
End If
x = i 'record the maximum numbers
End If
Next i
MsgBox Join(arr, ",")
End Sub

taller

由于楼主出题时，对于没有要求一定使用数组实现，所以对于所有结果正确的答复给予加分。

oobird

个人不懂数组，用循环果然费力气：

Sub yy()
Dim i%, a, b, v
On Error Resume Next
For i = 1 To 30
If Application.WorksheetFunction.CountIf(Columns(1), i) = 0 Then
a = a & "," & i
End If
Next
a = Right(a, Len(a) - 1)
b = Split(a, ",")
For i = 0 To UBound(b)
If b(i + 2) - b(i) = 2 Then
a = Replace(a, "," & b(i + 1) & ",", "-")
End If
Next
v = Array("-", ",")
b = Split(a, v)
For i = 0 To UBound(b)
If b(i + 1) - b(i) = 1 Then
a = Replace(a, "-" & b(i) & ",", "-")
End If
Next
[c5] = a
End Sub