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

EDIT2：感谢@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

尝试

db.doc.find().forEach(function(eachdoc){
if({'eachdoc.embdoc1.embdoc2.date1':{$exists:true}}){
  eachdoc.embdoc1.embdoc2.date2 = eachdoc.embdoc1.embdoc2.date1
}else{
  delete eachdoc.embdoc1.embdoc2.date2;
}
db.doc.save(eachdoc);
});

如果要避免出现空白，请创建一个联合。

Dim Words As range
with workSheets("Words")
    with intersect(.range("A:AT"), .usedrange)
        Set Words = .resize(.rows.count-1, .columns.count).offset(1, 0)
    end with
end with

要遍历该联合，您可能需要处理Range.Areas property。

Answer 2

我认为您需要遍历第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

Answer 3

可能是您在追求这个

Dim Words As Range
With Worksheets("Words")
    With Intersect(.Range("A:AT"), .UsedRange)
        Set Words = .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeConstants)
    End With
End With

根据多个具有动态范围的列在VBA中设置关键字

3 个答案: