求VBA代码， 判断数字是否连续，最后用缩略方式表示
0101-W1000-0002-001
0101-W1000-0002-002
0101-W1000-0002-003
0101-W1000-0002-004
0101-W1000-0002-005
0101-W1000-0002-006
0101-W1000-0004-001
0101-W1000-0004-002
0101-W1000-0004-003
0101-W1000-0004-004
0101-W1000-0004-005
0101-W1000-0009-001
0101-W1000-0009-002
0101-W1000-0009-003
0101-W1000-0009-004
0101-W1000-0009-005
0101-W1000-0009-006
主要是判断这一串数字中的第三块，即0002这一四位数字，那最后一个是0009，那就通过执行最后MSG弹出从1开始中间缺少的不连续的数字，但是这里有一要求，就是出现连续不出现的数字中间用短横表示，如上面，缺少了5,6,7,8,那就需要表示为5-8，那上面最后表示出的数据应该是：1,3,5-8
最新回答
天边シ深海
2024-04-21 04:22:44
Private Sub CommandButton1_Click()
Dim sht As Worksheet '将表名称赋给变量sht便于书写代码
Dim Arr() As Integer '用于存储获取到的
字符串
Dim irow% '用于保存工作表的总行数
Dim i%, j% '循环变量
Dim tmp% '临时交换数据用的变量
Set sht = ThisWorkbook.Sheets("sheet1")
irow = sht.UsedRange.Rows.Count '获取工作表已使用的行数
ReDim Arr(1 To irow) '重新设置数组维数
'将获取到的字符串转换为数值后存入数组
For i = 1 To irow
tmp = Int(Mid(sht.Range("A" & i), 12, 4))
Arr(i) = tmp
Next i
'对数组元素进行从小到大的排序
For i = 1 To UBound(Arr())
For j = i To UBound(Arr())
If Arr(i) > Arr(j) Then
tmp = Arr(i)
Arr(i) = Arr(j)
Arr(j) = tmp
End If
Next j
Next i
'将数组中不重复元素重新排列
Dim n% '不重复的数组元素个数
n = 1
For j = 1 To UBound(Arr())
If Arr(n) <> Arr(j) Then
Arr(n + 1) = Arr(j)
n = n + 1
End If
Next j
ReDim Preserve Arr(1 To n) '重新分配数组，保留不重复的内容
'将序列中缺失的数保存到新数组
Dim newarr() As String
ReDim newarr(1 To UBound(Arr()))
If Arr(1) <> 1 Then '1到第一个数组元素间缺失的数
If Arr(1) - 1 = 1 Then
newarr(1) = "1"
Else
newarr(1) = "1" & "-" & Arr(1) - 1
End If
End If
'从第二个数组元素开始至数组末尾间缺失的数
For i = 1 To UBound(Arr()) - 1
If Arr(i + 1) - Arr(i) = 1 Then
'如果两个元素间的差为1，是序列
Else
If Arr(i + 1) - Arr(i) = 2 Then
'两个元素的差值为2
newarr(i + 1) = Arr(i) + 1
Else
'两个元素的差值大于2
If Arr(i + 1) - Arr(i) > 2 Then
newarr(i + 1) = Arr(i) + 1 & "→" & Arr(i + 1) - 1
End If
End If
End If
Next i
'输出数据到工作表的B列
For i = 1 To UBound(newarr())
sht.Range("B" & i) = newarr(i)
Next i
End Sub
侞此の゛肤浅
2024-04-21 04:56:18
Sub run()
Dim row As Integer‘扫描起始行
Dim str As String'用于存储每一行的字符串
Dim id As Integer'转换
Dim idarr(10) As Integer'存储一个0..9
Dim outstr As String’输出字符串
Dim i As Integer
Dim j As Integer
Dim Bool As Boolean
row = 1
Do
str = Sheets("Sheet1").Cells(row, 1)
If str = "" Then Exit Do
id = Val(Mid(str, 12, 4))
idarr(id - 1) = id
row = row + 1
Loop
outstr = ""
Bool = False
For i = 0 To 8
If idarr(i) = 0 Then
idarr(i) = i + 1
Else
idarr(i) = 0
End If
Next
i = 0
Bool = True
While i < 9
If idarr(i) <> 0 Then
If idarr(i + 1) = 0 Then
If (i + 1) <> 9 Then
outstr = outstr & idarr(i) & ","
Else
outstr = outstr & idarr(i)
End If
Bool = True
End If
If (idarr(i + 1) <> 0) And Bool Then
outstr = outstr & idarr(i) & "-"
Bool = False
End If
End If
i = i + 1
Wend
If Mid(outstr, Len(outstr), 1) = "," Then outstr = Mid(outstr, 1, Len(outstr) - 1)
MsgBox outstr
End Sub
追问
我这个不一定就是到9啊，最多有可能到999的哦~~~
追答
//我只是写了个原理，代码不太清晰，你如下该一下
Sub run()
Dim row As Integer
Dim str As String
Dim id As Integer
Dim idarr(1000) As Integer
Dim outstr As String
Dim i As Integer
Dim j As Integer
Dim Bool As Boolean
row = 1
Do
str = Sheets("Sheet1").Cells(row, 1)
If str = "" Then Exit Do
id = Val(Mid(str, 12, 4))
idarr(id - 1) = id
row = row + 1
Loop
outstr = ""
Bool = False
For i = 0 To 998
If idarr(i) = 0 Then
idarr(i) = i + 1
Else
idarr(i) = 0
End If
Next
i = 0
Bool = True
While i 0 Then
If idarr(i + 1) = 0 Then
If (i + 1) 9 Then
outstr = outstr & idarr(i) & ","
Else
outstr = outstr & idarr(i)
End If
Bool = True
End If
If (idarr(i + 1) 0) And Bool Then
outstr = outstr & idarr(i) & "-"
Bool = False
End If
End If
i = i + 1
Wend
If Mid(outstr, Len(outstr), 1) = "," Then outstr = Mid(outstr, 1, Len(outstr) - 1)
MsgBox outstr
End Sub
热门标签
