Question

我在excel中有一组字符。我想在集合中搜索一个单词。例如，我从输入框中得到“WATER”这个词，然后我想以六种方式在下面的范围内搜索“WATER”，然后为这些字符添加颜色索引：

>horizontal left to right
>horizontal right to left
>vertical top to bottom
>vertical bottom to top
>diagonal top to bottom
>diagonal bottom to top

    A  B  C  D  E  F 
1   r  a  h  k  c  f 
2   h  u  m  n  d  e
3   w  a  t  e  r  r
4   k  t  y  e  s  q
5   p  y  x  q  e  r

我搜索但找不到任何东西。这超出了我的技能，我想知道是否有人有关于这个问题的代码？

Answer 1

您列出的安排会产生以下数量的字符串：

水平5 + 5个字符串（向前和向后）
垂直（向下和向上）6 + 6个字符串
4 + 4弦对角线（从上到下，从下到上）

所以只需为3个案例中的每个案例创建简单的循环，并将序列中的所有字符连接到化妆字符串。之后，您需要做的就是使用SubString函数（VBA中的INSTR）搜索您要查找的单词。

循环的一个例子是（对于前向水平字符串）：

Dim S(4) as string
For i = 1 To 5
    S(i) = ""
    For j = 1 To 5
        S(i) = S(i) & Cells(i, j)
    Next        
Next

Answer 2

这样做。绝对不是最有效的，因为有很多移动到Excel并返回，但工作得很好。

Sub Cross_words_out()

Dim strSearch As String
    strSearch = "water" ' <<<< your search word

Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
Dim rngA As Range
'Make sure your character collection is your CurrentRegion
Set rngA = ws.Range("A1").CurrentRegion 
Dim lRows As Long
    lRows = rngA.Rows.Count
Dim lCols As Long
    lCols = rngA.Columns.Count
Dim str As String
Dim lEval As Long
Dim i As Long, j As Long, k As Long 'counters

    'Horizontal forward
    For i = 1 To lRows
        str = vbNullString
        For j = 1 To lCols
            str = str & ws.Cells(i, j).Value2
        Next
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = lEval To lEval + Len(strSearch) - 1
                ws.Cells(i, k).Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next

    'Horizontal backward
    For i = 1 To lRows
        str = vbNullString
        For j = lCols To 1 Step -1
            str = str & Cells(i, j).Value2
        Next
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = lCols - lEval + 1 To _
                    lCols - lEval - Len(strSearch) + 2 Step -1
                ws.Cells(i, k).Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next

    'Vertical downward
    For i = 1 To lCols
        str = vbNullString
        For j = 1 To lRows
            str = str & Cells(j, i).Value2
        Next
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = lEval To lEval + Len(strSearch) - 1
                ws.Cells(k, i).Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next

    'Vertical upward
    For i = 1 To lCols
        str = vbNullString
        For j = lRows To 1 Step -1
            str = str & Cells(j, i).Value2
        Next
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = lRows - lEval + 1 To _
                    lRows - lEval - Len(strSearch) + 2 Step -1
                ws.Cells(k, i).Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next

    'Diagonal top to bottom, forward
    For i = lRows To 1 Step -1
        str = vbNullString
        j = 1
        Do
            str = str & ws.Cells(i + j - 1, j).Value2
            j = j + 1
        Loop While Not ws.Cells(i + j - 1, j).Value2 = Empty
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = 1 To Len(strSearch)
                ws.Cells(i + lEval + k - 2, lEval + k - 1) _
                    .Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next
    For i = 2 To lCols
        str = vbNullString
        j = 0
        Do
            str = str & ws.Cells(1 + j, i + j).Value2
            j = j + 1
        Loop While Not ws.Cells(j, i + j).Value2 = Empty
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = 1 To Len(strSearch)
                ws.Cells(lEval + k - 1, i + lEval + k - 2) _
                    .Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next

    'Diagonal bottom to top, forward
    For i = lRows To 1 Step -1
        str = vbNullString
        j = i
        Do
            str = str & ws.Cells(j, 1 + i - j).Value2
            j = j - 1
        Loop While Not j < 1 And _
            Not ws.Cells(i, 1 + i - j).Value2 = Empty
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = 1 To Len(strSearch)
                ws.Cells(i - lEval - k + 2, lEval + k - 1) _
                    .Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next
    For i = 2 To lCols
        str = vbNullString
        j = 0
        Do
            str = str & ws.Cells(lRows - j, i + j).Value2
            j = j + 1
        Loop While Not j < 1 And _
            Not ws.Cells(lRows, i + j).Value2 = Empty
        lEval = InStr(1, str, strSearch)
        If lEval > 0 Then
            For k = 1 To Len(strSearch)
                ws.Cells(lRows - lEval - k + 2, i + lEval + k - 2) _
                    .Interior.ThemeColor = xlThemeColorAccent4
            Next
        End If
    Next

Set rngA = Nothing
Set ws = Nothing
End Sub

Excel VBA在字符的填字游戏中搜索单词

2 个答案: