Question

这是一个棘手的事情！

我想让一个单词或短短语从右向左在一行中的30个单元格中爬行，并在循环中连续重复，并且速度要足够慢以使其移动。

任何人都可以提供代码帮助！

我一次只能做到一个字符，但是我想使整个单词爬行，每个单元格一个字符。

这是迄今为止我所面临的最艰巨的vba挑战！

谢谢。

这是我的基本版本的代码段：

For CounterTxt = 1 To textLngt

    chaseEnd = chaseEnd + 1

    For CounterChase = chaseBeg To chaseEnd - 1 Step -1

        Worksheets("Sheet1").Cells(7, CounterChase + 1).Value = "" ' deleats previous chase position while running.
        Worksheets("Sheet1").Cells(7, CounterChase).Value = Mid(MyText, CounterTxt, 1)

        Sleep 20

    Next CounterChase

Next CounterTxt

Answer 1

Sub March()
    Dim str As String
    str = "Hello World"

    Dim rng As Range
    Set rng = Worksheets("Sheet1").Range("A1:Z1")

    rng.ClearContents

    Dim secondstr As String
    secondstr = str & Application.Rept(" ", rng.Cells.Count)

    Dim vlue As String
    vlue = StrConv(secondstr, vbUnicode)

    Dim substr() As String
    substr = Split(Left(vlue, Len(vlue) - 1), vbNullChar)


    Dim i As Long
    For i = rng.Cells.Count + rng.Column - 1 To rng.Column Step -1
        If i = rng.Column Then
            Dim j As Long
            For j = 0 To Len(str)
                Dim k As Long
                For k = 1 To Len(str) + 1
                    rng.Cells(1, k) = substr(j + k - 1)
                Next k
                Application.Wait Now() + 1 / (24 * 60 * 60#)
            Next j

        Else
            rng.Cells(1, i).Resize(, Application.Min(Len(secondstr), rng.Cells.Count - i + 1)) = substr
            Application.Wait Now() + 1 / (24 * 60 * 60#)
        End If

    Next i

    March


End Sub

Answer 2

利用@ScottCraner的StrConv(secondstr, vbUnicode)功能，并假设删除相关行中的单元格没有危害，这是另一种方法：

Sub CrawlItLeftwards(myText As String, chaseRow As Long, chaseBeg As Long)
    Dim chaseCol As Long, textLngt As Long

    textLngt = Len(myText)
    Cells(chaseRow, chaseBeg).Resize(, textLngt).Value = Split(StrConv(myText, vbUnicode), Chr(0)) 'write the text once
    For chaseCol = 1 To chaseBeg + textLngt - 1 ' delete the first column cell to make it crawl leftwards
        Cells(chaseRow, 1).Delete xlToLeft
        Application.Wait Now() + 1 / (24 * 60 * 60#)
    Next
End Sub

您可以这样称呼：

CrawlItLeftwards "Hello", 7, 10 ' make the string "Hello" crawl in row 7 from column 10 leftwards

当然，您可以将参数列表扩展为例如，包含所需的工作表：

Sub CrawlItLeftwards (myText As String, sht As Worksheet, chaseRow As Long, chaseBeg As Long)
    Dim chaseCol As Long, textLngt As Long

    textLngt = Len(myText)
    sht.Activate ' make sure you're looking at/acting in the relevant sheet
    Cells(chaseRow, chaseBeg).Resize(, textLngt).Value = Split(StrConv(myText, vbUnicode), Chr(0)) 'write the text once
    For chaseCol = 1 To chaseBeg + textLngt - 1 ' delete the first column cell to make it crawl leftwards
        Cells(chaseRow, 1).Delete xlToLeft
        Application.Wait Now() + 1 / (24 * 60 * 60#)
    Next
End Sub

并这样称呼它：

CrawlItLeftwards "Hello", Worksheets("Sheet1"), 7, 10 ' make the string "Hello" crawl in sheets "Sheet1" row 7 from column 10 leftwards

使文本在一行中的一系列单元格中从右向左爬行

2 个答案: