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

我有一个Excel文件，我想写一个VBA代码。 我想检查特定列中的值，如果某个值有多个出现次数，则其他列中所有相关行的值将被总结并设置为自己。

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

我检查栏"C" 。 在第444 + 43434 + 43434 = 87312行中有3个出现0我总结了"B1" ， "B4"和"B6" ，这将是444 + 43434 + 43434 = 87312 ，并将这个总和设置为相同的列，即所有"B1" ， "B4"和"B6"单元格的值将为87312 。

我find了一个代码，用于查找所有有价值的事件，并且改变它适合我的问题。 但我找不到另一列的相关单元格。 这是我使用的代码：

 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 

我得到Runtime Error '91': Object variable or With block variable not set为此行：

 Set RelatedCells(i) = ws.Cells(FoundCells(i).Row, ColNumber) 

我删除了Set并得到了同样的错误。 哪里不对？

Answer 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 

没有testing。 此外，这假定FindAll函数完美地工作。
此外，我没有明确使用WorksheetFunction，但它也应该工作。 HTH

Answer 2

你可以使用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 

Answer 3

就像在旁边重申，尝试和更好地解释我在我的评论中指出的重新访问一个范围的相关细胞（i）其中相关细胞是一个范围对象 – 这归结于调用相关细胞范围对象的项目方法，所以除非当这样做的时候，RelatedCells对象实际上是存在的，因为VBA会抛出你所看到的错误types，因为你不能在不存在的对象上调用一个方法

另一种更简单的方法是通过RelatedCells（i），您试图在第i个位置参考细胞：

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

所以你需要首先设置一些引用，这些引用都是由RelatedCells对象提供的：

• 这个范围的第一个单元将作为参考单元
• 其形状 – 行数和列数 – 将决定偏移模式

希望有助于澄清一点