[已解决]请教这两组代码合到一起怎么样写

东方智彩 · 发表于 2012-2-12 09:12

Sub test()
Dim A, i%
With Sheets("sheet1")
      A = .Range("b4:c" & .Range("b4").End(xlDown).Row)
End With
For i = 1 To UBound(A)
      A(i, 2) = pd(A(i, 1))
Next i
[c4].Resize(UBound(A), 1) = Application.Index(A, 0, 2)
End Sub

Function pd(x) '判断
Dim b%, s%, g%
100:
pd = x
b = Left(x, 1)
s = Mid(x, 2, 1)
g = Right(x, 1)
'如果百位和十位相同 , 那么十位加1取尾
If b = s Then
      x = b & Right((s + 1), 1) & g
      GoTo 100
End If
'如果十位和个位相同 , 那么个位加1取尾
If s = g Then
      x = b & s & Right((g + 1), 1)
      GoTo 100
End If
'如果个位和百位相同 , 那么个位加1取尾
If g = b Then
      x = b & s & Right((g + 1), 1)
      GoTo 100
End If
'如3个数码全相同,第2位加1取尾,第3位加2取尾
If Replace(x, b, "", , 3) = "" Then
      pd = b & Right((s + 1), 1) & Right((g + 2), 1)
End If
End Function

http://www.excelpx.com/thread-222098-1-2.html
请教版主或高手这两组代码合到一起怎么样写,等待指教谢谢!

最佳答案

月排行榜 / 总排行榜

爱疯

2012-2-12 13:36

Sub test()
Dim A, i%, b%, s%, g%, x%
With Sheets("sheet1")
A = .Range("b4:c" & .Range("b4").End(xlDown).Row)
End With
For i = 1 To UBound(A)
x = A(i, 1)
100:
A(i, 2) = x
b = Left(x, 1)
s = Mid(x, 2, 1)
g = Right(x, 1)
'如果百位和十位相同 , 那么十位加1取尾
If b = s Then
x = b & Right((s + 1), 1) & g
GoTo 100
End If
'如果十位和个位相同 , 那么个位加1取尾
If s = g Then
x = b & s & Right((g + 1), 1)
GoTo 100
End If
'如果个位和百位相同 , 那么个位加1取尾
If g = b Then
x = b & s & Right((g + 1), 1)
GoTo 100
End If
'如3个数码全相同,第2位加1取尾,第3位加2取尾
If Replace(x, b, "", , 3) = "" Then
A(i, 2) = b & Right((s + 1), 1) & Right((g + 2), 1)
End If
A(i, 2) = x
Next i
[c4].Resize(UBound(A), 1) = Application.Index(A, 0, 2)
End Sub

复制代码

Book1d.rar (19.3 KB, 下载次数: 13)

雄鹰 · 发表于 2012-2-12 09:21

本帖最后由雄鹰于 2012-2-12 09:21 编辑

这样不是很好吗？
如果一定要合并：
Sub test()
Dim A, i%
With Sheets("sheet1")
      A = .Range("b4:c" & .Range("b4").End(xlDown).Row)
End With
For i = 1 To UBound(A)
         x = A(i, 1)
         b = Left(x, 1)
         s = Mid(x, 2, 1)
         g = Right(x, 1)
         '如果百位和十位相同 , 那么十位加1取尾
         If b = s Then
            x = b & Right((s + 1), 1) & g
            GoTo 100
         End If
         '如果十位和个位相同 , 那么个位加1取尾
         If s = g Then
            x = b & s & Right((g + 1), 1)
            GoTo 100
         End If
         '如果个位和百位相同 , 那么个位加1取尾
         If g = b Then
            x = b & s & Right((g + 1), 1)
            GoTo 100
         End If
         '如3个数码全相同,第2位加1取尾,第3位加2取尾
         If Replace(x, b, "", , 3) = "" Then
            pd = b & Right((s + 1), 1) & Right((g + 2), 1)
         End If
            A(i, 2) = pd
Next i
[c4].Resize(UBound(A), 1) = Application.Index(A, 0, 2)
End Sub

请测试是否与原代码效果一致。

qqyyh · 发表于 2012-2-12 09:32

向你们学习了!

lzclzch · 发表于 2012-2-12 10:14

学习中谢谢高手

BAIXINGR · 发表于 2012-2-12 10:26

你也可以在需要运行下边代码时，调用下边的代码啊，调用就用 CAII 加程序明

F962506113 · 发表于 2012-2-12 11:23

向各位高手学习了

爱疯 · 发表于 2012-2-12 13:36

Sub test()
Dim A, i%, b%, s%, g%, x%
With Sheets("sheet1")
A = .Range("b4:c" & .Range("b4").End(xlDown).Row)
End With
For i = 1 To UBound(A)
x = A(i, 1)
100:
A(i, 2) = x
b = Left(x, 1)
s = Mid(x, 2, 1)
g = Right(x, 1)
'如果百位和十位相同 , 那么十位加1取尾
If b = s Then
x = b & Right((s + 1), 1) & g
GoTo 100
End If
'如果十位和个位相同 , 那么个位加1取尾
If s = g Then
x = b & s & Right((g + 1), 1)
GoTo 100
End If
'如果个位和百位相同 , 那么个位加1取尾
If g = b Then
x = b & s & Right((g + 1), 1)
GoTo 100
End If
'如3个数码全相同,第2位加1取尾,第3位加2取尾
If Replace(x, b, "", , 3) = "" Then
A(i, 2) = b & Right((s + 1), 1) & Right((g + 2), 1)
End If
A(i, 2) = x
Next i
[c4].Resize(UBound(A), 1) = Application.Index(A, 0, 2)
End Sub

复制代码

Book1d.rar (19.3 KB, 下载次数: 13)

东方智彩 · 发表于 2012-2-12 17:12

经测试效果正确,谢谢爱疯版主

东方智彩 · 发表于 2012-2-12 17:15

雄鹰发表于 2012-2-12 09:21
这样不是很好吗？
如果一定要合并：
Sub test()

谢谢雄鹰的热情解答，代码未能测试成功

		自动登录	找回密码
密码			注册

[已解决]请教这两组代码合到一起怎么样写

评分