自动续写每位加一数值

laojiu369

求助：在单元格F2手工输入数值（黑色），求用VBA代码自动续写出单元格F3-F11数值（红色部分）

详见附表。
预谢！

laojiu369

再说一句：逢9变0。

gwjkkkkk

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ar, strTar$, strJoin$, i, m&, n&, s&
   
    If Target.Address <> "$F$2" Then Exit Sub
    If IsNumeric(Target.Value) = False Then Exit Sub
   
    Application.EnableEvents = False
        strTar = Right([F2].Value, 1)
        n = Len([F2].Value)
        For i = 1 To 10
            strJoin = strJoin & "0123456789"
        Next i
        s = InStr(strJoin, strTar) + 1
        ReDim ar(1 To 10, 0)
        For i = s To Len(strJoin) Step n
            m = m + 1
            ar(m, 0) = Mid(strJoin, i, n)
            If m = 10 Then Exit For
        Next i
        [F3].Resize(10) = ar
    Application.EnableEvents = True
End Sub

gwjkkkkk

请参考附件。。。

laojiu369

gwjkkkkk老师您好：
您写的代码很好，我在这里表示万分感谢。但不是我所要求的，您可能理解与我要求有点偏差。
我所求的是：每一位数字下面对应的位置都比上一个单元格内的数字多1，不是下格首位数字比上格末位数字多1.
完成之后，每一位置竖看都是相邻数字，如：2345678901.
还请老师再出手相帮。
再：最好加一个按钮，输入首组数字后，点击按钮。下面数字执行续写。
给您添麻烦了！

laojiu369

请参考下面图片-完成后的效果。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, strTxt$
   
    strTxt = [F2].Value
    If Len(strTxt) = False Then Exit Sub
    If IsNumeric(strTxt) = False Then Exit Sub
   
    ReDim ar(1 To 10, 0)
    For i = 1 To UBound(ar)
        If i = 1 Then
             ar(i, 0) = strTxt
        Else
            ar(i, 0) = ar(i - 1, 0)
            ReDim br(1 To Len(ar(i, 0)))
            For j = 1 To UBound(br)
                br(j) = Mid(ar(i, 0), j, 1)
                If br(j) = "9" Then br(j) = 0 Else br(j) = br(j) + 1
            Next j
            ar(i, 0) = Join(br, "")
        End If
    Next i
   
    Columns("F").ClearContents
    [F2].Resize(10) = ar
    Beep
End Sub

gwjkkkkk

请参考。。。

laojiu369

gwjkkkkk老师：
很好了，完全符合我的要求，您受累了，表示由衷感谢！
下载学习，再慢慢消化。
好人一生平安！

大灰狼1976

1. Sub test()
   
2. Dim i&, j&, arr
   
3. For i = 3 To 11
   
4.   arr = Split(Cells(i - 1, "f"), "9")
   
5.   For j = 0 To UBound(arr)
   
6.     If Len(arr(j)) Then arr(j) = Val(arr(j)) + Val(String(Len(arr(j)), "1"))
   
7.   Next j
   
8.   Cells(i, "f") = Join(arr, "0")
   
9. Next i
   
10. End Sub

复制代码