Question

我在vba中有两个for循环，它们遍历列b并检查当前单元格中的第一个单词是否与任何其他单元格中的第一个单词相同，如果是，则将它们复制到另一个列中，从而进行分组类似的项目。但是，当我去复制并粘贴它找到的匹配时，它只复制和粘贴匹配，而不是它正在比较的原始单元格。我想在分组中有匹配和原始单元格，但我不确定在哪里修改我的代码，所以它会这样做。我对vba很新，所以任何帮助都会非常感激。

Sub FuzzySearch()

Dim WrdArray1() As String, WrdArray2() As String, i As Long, Count As Long, Rng1 As Range
Dim WS As Worksheet, positionx As Long, positiony As Long
Dim rng2 As Range

    Set WS = ThisWorkbook.ActiveSheet
    With WS
        Set Rng1 = .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
    End With

For i = 1 To Rng1.Rows.Count
With Columns("B")
    .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas).Activate
End With

position = 1

For j = 1 To Rng1.Rows.Count

WrdArray1 = Split(ActiveCell.Value, " ")
ActiveCell.Offset(1).Activate
WrdArray2 = Split(ActiveCell.Value, " ")

If UBound(WrdArray2) < 0 Then

    End
End If

If WrdArray1(0) = WrdArray2(0) Then
    ActiveCell.Copy Destination:=ActiveSheet.Range("C" & position)
    position = position + 1
    Count = Count + 1
End If

Next j

Next i



End Sub

Answer 1

鉴于您正在使用数组和范围的混合，使用循环中的最终输出（包括比较器）填充其中一个数组并将数组传输到工作表中可能会更容易且更少混淆单一命令。

但是，也许可以考虑以下方法让Excel完成所有“繁重的工作”。这是相同数量的代码行，但我已将其注释为您的信息。这说明了在循环中填充数组并将其传输到Range。根据您的具体情况更改各种变量。

Sub grpAndCount()

Dim ws As Worksheet
Dim strow As Long, endrow As Long, stcol As Long
Dim coloffset As Long, r As Long
Dim newstr As String
Dim drng As Range
Dim strArr() As String

'Data start r/c
strow = 6   'Row 6
stcol = 2   'Col B

'Offset no of Cols from Data to place results
coloffset = 2

Set ws = Sheets("Sheet1")

    With ws
        'find last data row
        endrow = Cells(Rows.Count, stcol).End(xlUp).Row

            'for each data row
            For r = strow To endrow
                'get first word
                newstr = Left(.Cells(r, stcol), InStr(.Cells(r, stcol), " ")-1)
                'put string into array
                ReDim Preserve strArr(r - strow)
                strArr(r - strow) = newstr
            Next r

        'put array to worksheet
        Set drng = .Range(.Cells(strow, stcol + coloffset), .Cells(endrow, stcol + coloffset))
        drng = Application.Transpose(strArr)

        'sort newly copied range
        drng.Sort Key1:=.Cells(strow, stcol + coloffset), Order1:=xlAscending, Header:=xlNo

        'provide a header row for SubTotal
        .Cells(strow - 1, stcol + coloffset) = "Header"

        'resize range to include header
        drng.Offset(-1, 0).Resize(drng.Rows.Count + 1, 1).Select

        'apply Excel SubTotal function
        Application.DisplayAlerts = False
        Selection.Subtotal GroupBy:=1, Function:=xlCount, Totallist:=Array(1)
        Application.DisplayAlerts = True

        'remove 'Header' legend
        .Cells(strow - 1, stcol + coloffset) = ""
    End With

End Sub

vba中的类似分组

1 个答案: