Поиск повторений значений и изменение значения некоторой другой ячейки на основе результата поиска в VBA excel

У меня есть файл Excel, для которого я хочу написать код VBA. Я хочу проверить значения в определенном столбце, и если какое-то значение имеет более одного вхождения, значение всех связанных строк в некотором другом столбце будет суммировано и задано для себя.

Позвольте привести вам пример. У меня есть рабочий лист:

введите описание изображения здесь

Я проверяю колонку "C" . В строках 1, 4 и 6. Есть 3 вхождения 0 Я суммирую значение "B1" , "B4" и "B6" , который будет 444 + 43434 + 43434 = 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 

Я получаю Runtime Error '91': Object variable or With block variable not set для этой строки:

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

Я удалил Set и получил ту же ошибку. Что не так?

Основываясь на вашем комментарии, это должно работать:

 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, но он также должен работать. НТН

Не могли бы вы просто использовать функцию 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 

Так же, как в сторону, чтобы повторить и попытаться лучше объяснить то, что я указываю в своем комментарии, обращаясь к диапазону с помощью Связанных Cells (i), где RelatedCells – это объект диапазона – это сводится к вызову метода Item на объекте RangeCellCode, поэтому, если объект RelatedCells фактически существует, когда вы делаете это, VBA будет вызывать тип ошибки, которую вы видите, поскольку вы не можете вызвать метод для объекта, который не существует

Еще один более ленивый и, возможно, более простой способ взглянуть на него – это то, что со ссылкой на CellCells (i) вы пытаетесь сослаться на ячейку в i-й позиции:

  • по отношению к определенной ячейке ссылки
  • смещение от этой ячейки ссылки определенным количеством строк и столбцов

Поэтому вам нужно иметь какую-то ссылку, которая задана в первую очередь – все они предоставлены объектом RelatedCells:

  • первая ячейка этого диапазона будет действовать как ячейка ссылки
  • его форма – количество строк и столбцов – определяет шаблон смещения

Надежда, которая помогает немного разъяснить

  • Создание таблиц и имен с кодом ошибки 1004
  • Ошибка «1004» в excel VBA, но иногда отлично работает
  • Застрял в режиме работы при сортировке
  • Ошибка выполнения 13 в цикле for i, которая использовалась для работы
  • vba enums error: «Недопустимая внутренняя процедура».
  • Ошибка 1004: ошибка, определяемая приложением или объект-ошибка. Excel
  • Ошибка VBA Runtime Error 91 Переменная объекта не задана - что я делаю неправильно?
  • Excel VBA- Ошибка выполнения 1004, открывающая книгу
  • Excel VBA: ошибка времени выполнения '91' при втором присвоении переменной Object
  • Ошибка выполнения 438 при копировании из одной книги в другую
  • Код перестает работать после ошибки
  • Interesting Posts

    Убить последний созданный экземпляр Excel в диспетчере задач vb.net

    Необязательный аргумент в VBA вызывает ошибку при выполнении

    Как эффективно удалять строки на основе сравнения

    Excel VBA для установки переменной в рабочий лист

    Пытаться получить доступ к объекту COM-объекта excel в качестве администратора

    Кодирование VBA – Генерация случайной переменной

    Внешние данные «из Access» создают различный список доступных запросов / таблиц в зависимости от пользователя

    Найти минимальное количество на нескольких листах с помощью панд

    Циклы сумм VBA в массивах формул

    Подкатегория VBA выходит за пределы выбора

    Несколько гиперссылок в Apache POI

    Использование InputBox для ввода пользовательского ввода в виде текстовой строки в качестве переменной в формуле

    Объединение нескольких массивов с использованием php

    как вставить список массивов в таблицу?

    Workbook_BeforeSave с каждой активной книгой ActiveWorkbook

    Давайте будем гением компьютера.