vba - 基于具有动态范围的多列在 VBA 中设置关键字

Question

我需要根据多列设置一些关键字。我目前使用的代码对于一列效果很好:

Dim Words As range
Set Words = Sheets("Words").range("A2").Resize(Sheets("Words").range("A" & Rows.Count).End(xlUp).Row - 1)

但是如果我将其扩展为 A:AT 则不起作用。

基本上我想做的就是将范围 A2:Ax 一直到 AT2:ATx 中的所有单词存储起来，但问题是每列都有不同数量的需要存储的单词。

编辑:根据要求，我目前的完整代码

Sub Keyword()
Application.ScreenUpdating = False

Dim Words As range
Dim strText As range
Dim c As range
Dim r As range

Set Words = Sheets("Words").range("A2:AT2").Resize(Sheets("Words").range("A" & Rows.Count).End(xlUp).Row - 1)

Set strText = Sheets("Verbatims").range("BJ2").Resize(Sheets("Verbatims").range("BJ" & Rows.Count).End(xlUp).Row - 1)
For Each c In strText
    For Each r In Words
        If InStr(1, UCase(c), UCase(r), 1) > 0 Then
            c.Offset(, 29) = c.Offset(, 29) & ", " & r
        End If
    Next r
    If Len(c.Offset(, 29)) > 0 Then c.Offset(, 29) = Right(c.Offset(, 29), (Len(c.Offset(, 29)) - 2))
Next c

Application.ScreenUpdating = True
End Sub

编辑2:感谢@jamheadart，我已经更新了我的代码并且现在可以使用了。

Sub Keywords()

Dim WordsRange As range
Dim hRow As Long
Dim i As Long

With Worksheets("Words")
    For i = 1 To 46
        If hRow < Cells(Rows.Count, i).End(xlUp).Row Then hRow = Cells(Rows.Count, i).End(xlUp).Row
    Next i
    Set WordsRange = range("A2:AT" & hRow)
End With

Dim c As range
Dim Words As Collection
Set Words = New Collection

For Each c In WordsRange
    If c.Value <> "" Then Words.Add c.Value
Next

Dim strText As range
Dim x As range
Dim r As Variant

Set strText = Sheets("Verbatims").range("BJ2").Resize(Sheets("Verbatims").range("BJ" & Rows.Count).End(xlUp).Row - 1)
For Each x In strText
    For Each r In Words
        If InStr(1, UCase(x), UCase(r), 1) > 0 Then
            x.Offset(, 29) = x.Offset(, 29) & ", " & r
        End If
    Next r
    If Len(x.Offset(, 29)) > 0 Then x.Offset(, 29) = Right(x.Offset(, 29), (Len(x.Offset(, 29)) - 2))
Next x

End Sub

Answer 1

我认为您需要遍历第 1 至 46 列(AT)并找到最大行，我通常不会依赖UsedRange，因为它有时无法在工作表上注册更新，但我怀疑您没有编写大量内容长线。

Sub eh()
Dim WordsRange As Range
Dim hRow As Long
Dim i As Long
For i = 1 To 46
    If hRow < Cells(Rows.Count, i).End(xlUp).Row Then hRow = Cells(Rows.Count, i).End(xlUp).Row
Next i
Set WordsRange = Range("A2:AT" & hRow)
MsgBox (WordsRange.Address)
End Sub

也许您想将所有不是“”的内容放入关键字列表中进行检查，而不是检查范围？

Dim c as Range
Dim Words as Collection
For Each c In WordsRange
    If c.Value2 <> "" Then Words.Add c.Value2
Next