根据VBA excel中的搜索结果查找重复值并更改其他单元格的值

我有一个Excel文件，我想为它编写VBA代码。我想检查一个特定列中的值，如果某个值有多个引用，则会将其他列中所有相关行的值相加，并自行设置

让我给你举个例子。我有一个这样的工作表：

我选中列

“C”

。第1、4和6行中出现了3次

0

。我将

“B1”

、

“B4”

和

“B6”

的值相加，即

444+4343434=87312

，并为相同的列设置此总和，即所有

“B1”

、

“B4”

和

“B6”

单元格都将具有值

87312

我找到了一个代码，用于查找某个值的所有匹配项，经过一些更改后，它适合我的问题；但我在另一列找不到相关的单元格。这是我使用的代码：

Sub FindRepetitions()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim SearchRange As Range
    Dim FindWhat As Variant
    Dim FoundCells As Range
    Dim FoundCell As Range
    Dim Summation As Integer
    Dim ColNumber As Integer
    Dim RelatedCells As Range

    Set ws = ActiveWorkbook.Sheets("Sheet1")
    lastRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
    Set SearchRange = ws.Range("C1:C" & lastRow)

    For Each NewCell In SearchRange
        FindWhat = NewCell.Value
        Set FoundCells = FindAll(SearchRange:=SearchRange, _
                            FindWhat:=FindWhat, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            MatchCase:=False, _
                            BeginsWith:=vbNullString, _
                            EndsWith:=vbNullString, _
                            BeginEndCompare:=vbTextCompare)

        If FoundCells.Count > 1 Then
            ' 2 is the Number of letter B in alphabet '
            ColNumber = 2
            For i = 1 To FoundCells.Count
                Set RelatedCells(i) = ws.Cells(FoundCells(i).Row, ColNumber)
            Next
            Set Summation = Application.WorksheetFunction.Sum(RelatedCells)
            For Each RelatedCell In RelatedCells
                Set Cells(RelatedCell.Row, RelatedCell.Column).Value = Summation
            Next RelatedCell
        End If

    Next

End Sub



Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
                Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' FindAll
    ' This searches the range specified by SearchRange and returns a Range object
    ' that contains all the cells in which FindWhat was found. The search parameters to
    ' this function have the same meaning and effect as they do with the
    ' Range.Find method. If the value was not found, the function return Nothing. If
    ' BeginsWith is not an empty string, only those cells that begin with BeginWith
    ' are included in the result. If EndsWith is not an empty string, only those cells
    ' that end with EndsWith are included in the result. Note that if a cell contains
    ' a single word that matches either BeginsWith or EndsWith, it is included in the
    ' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
    ' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
    ' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
    ' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
    ' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
    ' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
    ' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim FoundCell As Range
    Dim FirstFound As Range
    Dim LastCell As Range
    Dim ResultRange As Range
    Dim XLookAt As XlLookAt
    Dim Include As Boolean
    Dim CompMode As VbCompareMethod
    Dim Area As Range
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim BeginB As Boolean
    Dim EndB As Boolean


    CompMode = BeginEndCompare
    If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
        XLookAt = xlPart
    Else
        XLookAt = LookAt
    End If

    ' this loop in Areas is to find the last cell
    ' of all the areas. That is, the cell whose row
    ' and column are greater than or equal to any cell
    ' in any Area.

    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)

    On Error GoTo 0
    Set FoundCell = SearchRange.Find(what:=FindWhat, _
            after:=LastCell, _
            LookIn:=LookIn, _
            LookAt:=XLookAt, _
            SearchOrder:=SearchOrder, _
            MatchCase:=MatchCase)

    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False ' Loop forever. We'll "Exit Do" when necessary.
            Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
            End If
            If Include = True Then
                If ResultRange Is Nothing Then
                    Set ResultRange = FoundCell
                Else
                    Set ResultRange = Application.Union(ResultRange, FoundCell)
                End If
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address = FirstFound.Address) Then
                Exit Do
            End If

        Loop
    End If

    Set FindAll = ResultRange

End Function

---

我删除了

集合

，得到了相同的错误。有什么问题吗？

您可以使用sumif函数吗

以下代码插入一列（以防止覆盖）使用sumif函数计算所需的值，然后将值复制回B列并删除临时列

Sub temp()
Dim ws As Worksheet
Dim lastrow As Long

Set ws = ActiveWorkbook.Sheets("Sheet1")
lastrow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row

'Insert a column so nothing is overwritten
Range("E1").EntireColumn.Insert

'Assign formula
Range("E1").Formula = "=sumif(C:C,C1,B:B)"
Range("E1:E" & lastrow).FillDown

'copy value back into column B
Range("B1:B" & lastrow).Value = Range("E1:E" & lastrow).Value

'delete column
Range("E1").EntireColumn.Delete

End Sub

---

根据您的评论，这应该是可行的：

Sub FindRepetitions()
    Dim ws As Worksheet, lastRow As Long, SearchRange As Range
    Set ws = ActiveWorkbook.Sheets("Sheet1")
    lastRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
    Set SearchRange = ws.Range("C1:C" & lastRow)
    '~~> First determine the values that are repeated
    Dim repeated As Variant, r As Range
    For Each r In SearchRange
        If WorksheetFunction.CountIf(SearchRange, r.Value) > 1 Then 
            If IsEmpty(repeated) Then
                repeated = Array(r.Value)
            Else
                If IsError(Application.Match(r.Value,repeated,0)) Then
                    ReDim Preserve repeated(Ubound(repeated) + 1)
                    repeated(Ubound(repeated)) = r.Value
                End If
            End If
        End If
    Next
    '~~> Now use your FindAll function finding the ranges of repeated items
    Dim rep As Variant, FindWhat As Variant, FoundCells As Range
    Dim Summation As Long
    For Each rep In repeated
        FindWhat = rep
        Set FoundCells = FindAll(SearchRange:=SearchRange, _
                        FindWhat:=FindWhat, _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByColumns, _
                        MatchCase:=False, _
                        BeginsWith:=vbNullString, _
                        EndsWith:=vbNullString, _
                        BeginEndCompare:=vbTextCompare).Offset(0, -1)
        '~~> Take note that we use Offset to return Cells in B instead of C
        '~~> Sum FoundCells
        Summation = WorksheetFunction.Sum(FoundCells)
        '~~> Output in those ranges
        For Each r In FoundCells
            r = Summation
        Next
    Next
End Sub

没有测试。此外，这还假设FindAll函数工作正常。

---

此外，我没有明确说明如何使用WorksheetFunction，但它也应该可以工作。HTH

作为旁白，我重申并尝试更好地解释我在评论中指出的内容，通过RelatedCells重新访问范围（I），其中RelatedCells是范围对象-这归结为对RelatedCells范围对象调用Item方法，因此，除非执行此操作时RelatedCells对象确实存在，否则VBA将抛出您看到的错误类型，因为您无法对不存在的对象调用方法

另一种更为简单的方法是，通过关联单元格（i），您试图引用第i个位置的单元格：

• 相对于某个参考单元格
• 从该引用单元格偏移一定数量的行和列

因此，您首先需要设置某种引用，这些引用都是由RelatedCells对象提供的：

• 此范围的第一个单元格将用作参考单元格
• 其形状（行数和列数）将决定偏移模式

---

希望这有助于澄清一点

在此之前您没有设置RelatedCells引用，是吗？如果是这样，RelatedCells（i）基本上代表RelatedCells。item（i）我认为-那么您试图在一个不存在的对象上应用item方法，我感到困惑。@@@你想达到什么目标？顺便说一句，FindAll已经找到了所有匹配项，为什么每个循环都要使用另一个？所以我认为这是多余的。你所说的

是什么意思？我将“B1”、“B4”和“B6”的值相加，并将此总和设置为相同的列，即“B1”、“B4”和“B6”

？求和这些值后，将它们设置回这些范围是什么意思？@IAmDranged，在第

行设置RelatedCells（i）=ws.Cells（FoundCells（i）.Row，ColNumber）

中，我第一次尝试设置RelatedCells项的值；我应该事先做些什么吗？我不是VBA专家，如果您不介意的话，请解释更多。@L42，I=1的循环

用于查找单元格。Count

试图查找相关单元格的总和；我还解释了问题中的总结。RelatedCells中每个RelatedCells的另一个循环

正在尝试设置RelatedCells的总和。如果你能给我提供一些简单的方法，那就太好了。我做到了。请看我的帖子。如果我对你的问题的理解是正确的，那就行了。如果有你不理解的部分，请注释掉。我不认为你的代码对我的数据有效。我想求和的单元格不在一起；这两个单元格都不是我要填充的。它适用于您发布的示例。单元格不需要在一起，如果只有一个单元格具有值，sumif将返回该值（因此不会更改任何内容）。试着在一个示例表上运行它，看看它是否提供了您所需要的。最好将公式=sumif（C:C，C1，B:B）放在第1行的一个单元格中，然后向下复制，看看该列是否给出了所需的结果。
Sub FindRepetitions()
    Dim ws As Worksheet, lastRow As Long, SearchRange As Range
    Set ws = ActiveWorkbook.Sheets("Sheet1")
    lastRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
    Set SearchRange = ws.Range("C1:C" & lastRow)
    '~~> First determine the values that are repeated
    Dim repeated As Variant, r As Range
    For Each r In SearchRange
        If WorksheetFunction.CountIf(SearchRange, r.Value) > 1 Then 
            If IsEmpty(repeated) Then
                repeated = Array(r.Value)
            Else
                If IsError(Application.Match(r.Value,repeated,0)) Then
                    ReDim Preserve repeated(Ubound(repeated) + 1)
                    repeated(Ubound(repeated)) = r.Value
                End If
            End If
        End If
    Next
    '~~> Now use your FindAll function finding the ranges of repeated items
    Dim rep As Variant, FindWhat As Variant, FoundCells As Range
    Dim Summation As Long
    For Each rep In repeated
        FindWhat = rep
        Set FoundCells = FindAll(SearchRange:=SearchRange, _
                        FindWhat:=FindWhat, _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByColumns, _
                        MatchCase:=False, _
                        BeginsWith:=vbNullString, _
                        EndsWith:=vbNullString, _
                        BeginEndCompare:=vbTextCompare).Offset(0, -1)
        '~~> Take note that we use Offset to return Cells in B instead of C
        '~~> Sum FoundCells
        Summation = WorksheetFunction.Sum(FoundCells)
        '~~> Output in those ranges
        For Each r In FoundCells
            r = Summation
        Next
    Next
End Sub