使文本在单行的单元格范围内从右向左爬行

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