Сравните диапазоны, чтобы узнать, равны ли они

Я работаю над своим компьютером для автоматизации цитаты в Excel с помощью VBA. Он состоит в поиске дубликатов, чтобы их можно было суммировать.

Например:

У меня есть следующая информация:

Щелкните здесь для файла Excel

Диапазон от A2: C4 представляет собой группу, в которой он содержит 28 болтов, 1 гайку для каждого болта и 1 шайбу для каждого болта.

A5: C7 – это еще одна группа, которая состоит из тех же 28 болтов, 1 гайка для каждого болта и 1 шайбы для каждого болта.

A11: C13 – это еще одна группа, но разница в том, что для этого есть 2 гайки и 2 шайбы на болт.

Таким образом, это не будет суммой

Это было бы результатом:

Выходная информация

У меня есть следующий код, где он просматривает только все ячейки, я не могу найти способ заставить его выглядеть в группах или диапазонах.

Sub Macro1() Dim LastRow As Long, LastColumn As Long Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With wSrc LastRow = .Range("B" & .Rows.Count).End(xlUp).Row Set rng = .Range("B1:B" & LastRow) LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2 rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, LastColumn), unique:=True Z = .Cells(.Rows.Count, LastColumn).End(xlUp).Row LastColumn = LastColumn + 1 .Cells(1, LastColumn).Value = "Total" .Range(.Cells(2, LastColumn), .Cells(Z, LastColumn)).Formula = _ "=SUMIF(" & rng.Address & "," & .Cells(2, LastColumn - 1).Address(False, False) & "," & rng.Offset(, 1).Address & ")" End With With Application .ScreenUpdating = Truek .Calculation = xlCalculationAutomatic End With End Sub 

Нажмите ниже для файла Excel

Ниже приведен подход, в котором используются объекты User Defined Object для Hardware и Hardware.

Мы могли бы создать более компактный код с меньшим количеством циклов, но, если не будет значительной проблемы с производительностью, это, вероятно, более читаемо и может быть легче адаптировано к будущим потребностям.

Мы создаем два модуля класса ( и обязательно переименуем их, как указано в коде ). Один модуль класса предназначен для аппаратных элементов, второй для разных групп.

Свойства элементов оборудования – это описание, вес на элемент и количество элементов.

Свойства групп устройств представляют собой набор элементов оборудования и количество элементов в этой группе.

Затем мы объединяем аппаратные группы в набор уникальных аппаратных групп.

Когда код написан, вы можете комбинировать другие способы генерации отчетов других типов.

Результаты:

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

Класс 1


 '**Rename: cHardware** Option Explicit Private pDescription As String Private pWt As Double Private pItemCount As Long Public Property Get Description() As String Description = pDescription End Property Public Property Let Description(Value As String) pDescription = Value End Property Public Property Get Wt() As Double Wt = pWt End Property Public Property Let Wt(Value As Double) pWt = Value End Property Public Property Get ItemCount() As Long ItemCount = pItemCount End Property Public Property Let ItemCount(Value As Long) pItemCount = Value End Property 

Класс 2


 '**Rename: cHardwareGrp** Option Explicit Private pHW As cHardWare Private pHWs As Collection Private pQty As Long Private Sub Class_Initialize() Set pHWs = New Collection End Sub Public Property Get HW() As cHardWare Set HW = pHW End Property Public Property Let HW(Value As cHardWare) Set pHW = Value End Property Public Property Get HWs() As Collection Set HWs = pHWs End Property Public Function AddHW(Value As cHardWare) Dim I As Long, J As Long If pHWs.Count = 0 Then pHWs.Add Value Else 'Insert in sorted order For J = pHWs.Count To 1 Step -1 If pHWs(J).Description <= Value.Description Then Exit For Next J If J = 0 Then pHWs.Add Value, before:=1 Else pHWs.Add Value, after:=J End If End If End Function Public Property Get Qty() As Long Qty = pQty End Property Public Property Let Qty(Value As Long) pQty = Value End Property 

Регулярный модуль


 Option Explicit Sub SummarizeHW() Dim wsRes As Worksheet, wsSrc As Worksheet, rRes As Range Dim vSrc As Variant, vRes() As Variant Dim cHW As cHardWare, colHW As Collection Dim cHWG As cHardwareGrp, colHWG As Collection Dim colUniqueHWG As Collection Dim I As Long, J As Long, K As Long Dim lQTY As Long Dim S As String Dim V As Variant Dim RE As Object, MC As Object 'Set Source and Results Worksheets and Ranges Set wsSrc = Worksheets("Hoja1") Set wsRes = Worksheets("Hoja2") Set rRes = wsRes.Cells(1, 1) 'Get Source Data With wsSrc vSrc = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) _ .Offset(columnoffset:=-1).Resize(columnsize:=3) End With 'Set up regex to extract number of HW items in description Set RE = CreateObject("vbscript.regexp") With RE .Global = False .Pattern = "^\((\d+)\)\s*" .MultiLine = True End With 'Collect unique list of hardware items ' compute the weight of each single item Set colHW = New Collection On Error Resume Next For I = 2 To UBound(vSrc, 1) 'assumes header row If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1) Set cHW = New cHardWare With cHW S = vSrc(I, 2) If RE.test(S) = True Then Set MC = RE.Execute(S) .ItemCount = CLng(MC(0).submatches(0)) Else .ItemCount = 1 End If .Wt = vSrc(I, 3) / lQTY / .ItemCount .Description = S colHW.Add cHW, .Description End With Next I On Error GoTo 0 'Collect the Hardware Groups 'HW group starts if there is a "Qty" in column 1 Set colHWG = New Collection For I = 2 To UBound(vSrc, 1) If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1) Set cHWG = New cHardwareGrp Do With cHWG .HW = colHW(vSrc(I, 2)) .AddHW .HW .Qty = lQTY End With I = I + 1 If I > UBound(vSrc, 1) Then Exit Do Loop Until vSrc(I, 1) <> "" colHWG.Add cHWG I = I - 1 Next I 'Collect the unique hardware groups ' A group is defined by ALL of the hardware components being identical ' in both type and quantity. Therefore, we can concatenate them as a key Set colUniqueHWG = New Collection On Error Resume Next For I = 1 To colHWG.Count With colHWG(I) ReDim V(1 To .HWs.Count) For J = 1 To UBound(V) V(J) = .HWs(J).Description Next J S = Join(V, "|") colUniqueHWG.Add colHWG(I), S Select Case Err.Number Case 457 'a duplicate so add the QTY colUniqueHWG(S).Qty = colUniqueHWG(S).Qty + .Qty Err.Clear Case Is <> 0 'error stop Debug.Print Err.Number, Err.Description End Select End With Next I On Error GoTo 0 'Final Report '# of columns = 3 '# of rows = sum of the number of HW items in each group + 1 for the header J = 0 For I = 1 To colUniqueHWG.Count J = J + colUniqueHWG(I).HWs.Count Next I ReDim vRes(0 To J, 1 To 3) 'Column headers vRes(0, 1) = "Qty" vRes(0, 2) = "Hardware Description" vRes(0, 3) = "Weight" 'populate the results array' K = 1 For I = 1 To colUniqueHWG.Count With colUniqueHWG(I) For J = 1 To .HWs.Count If J = 1 Then vRes(K, 1) = .Qty vRes(K, 2) = .HWs(J).Description vRes(K, 3) = .Qty * .HWs(J).Wt * .HWs(J).ItemCount K = K + 1 Next J End With Next I 'Write the results on a new sheet Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2)) With rRes .EntireColumn.Clear .Value = vRes .ColumnWidth = 255 With Rows(1) .Font.Bold = True .HorizontalAlignment = xlCenter End With .EntireColumn.AutoFit End With End Sub 

Хммм. Из ваших комментариев видно, что оборудование не всегда может быть в одном порядке. Я добавлю процедуру сортировки для нашего поколения групп, чтобы это не имело значения.

EDIT : функция AddHW была изменена для вставки элементов HW в отсортированном порядке. Поскольку должно быть только несколько элементов, этот сортировка вставки должна быть адекватной.

Принимая иной подход.

  1. использовать структуру; три строки определяют его
  2. Положить результаты на другую вкладку

Этот вход …

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

генерирует этот результат …

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

используя этот код …

 Option Explicit Sub Macro1() Dim LastRow As Long, LastColumn As Long Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1") Dim tmpSrc As Worksheet Dim outRng As Range, inRng As Range Dim iLoop As Long, jLoop As Long, QSum As Long ' turn off updating for speed With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With ' setup - tmpSrc is the working and final result Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc) Set inRng = wSrc.UsedRange inRng.Copy tmpSrc.Range("A1").PasteSpecial (xlPasteAll) With tmpSrc .Name = "Hoja2" Set outRng = .UsedRange LastRow = .UsedRange.Rows.Count LastColumn = .UsedRange.Columns.Count End With ' loop down through the range For iLoop = 2 To LastRow If outRng.Cells(iLoop, 1) <> "" Then QSum = outRng.Cells(iLoop, 1).Value For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match ' matches are defined by all three rows in column B If outRng.Cells(jLoop, 1) <> "" And _ outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _ outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _ outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then QSum = QSum + outRng.Cells(jLoop, 1).Value outRng.Rows(jLoop + 2).Delete outRng.Rows(jLoop + 1).Delete outRng.Rows(jLoop).Delete LastRow = LastRow - 3 End If Next jLoop outRng.Cells(iLoop, 1).Value = QSum End If Next iLoop For iLoop = 1 To 3 outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth Next iLoop With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub 

Редактировать:

  • Суммирующие грузы для болтов, гаек и шайб
  • Проверка на случай, когда гайки и шайбы отображаются в обратном порядке
  • nb Я использую .UsedRange, чтобы найти последнюю строку и последний столбец. Другие методы доступны.

,

 Option Explicit Sub Macro1() Dim LastRow As Long, LastColumn As Long Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1") Dim tmpSrc As Worksheet Dim outRng As Range, inRng As Range Dim iLoop As Long, jLoop As Long, QSum As Long Dim WSum1 As Double, WSum2 As Double, WSum3 As Double ' turn off updating for speed With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With ' setup - tmpSrc is the working and final result Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc) Set inRng = wSrc.UsedRange inRng.Copy tmpSrc.Range("A1").PasteSpecial (xlPasteAll) With tmpSrc .Name = "Hoja2" Set outRng = .UsedRange LastRow = .UsedRange.Rows.Count LastColumn = .UsedRange.Columns.Count End With ' loop down through the range For iLoop = 2 To LastRow If outRng.Cells(iLoop, 1) <> "" Then QSum = outRng.Cells(iLoop, 1).Value WSum1 = outRng.Cells(iLoop, 3).Value WSum2 = outRng.Cells(iLoop + 1, 3).Value WSum3 = outRng.Cells(iLoop + 2, 3).Value For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match ' matches are defined by all three rows in column B If outRng.Cells(jLoop, 1) <> "" And _ outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _ outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _ outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then QSum = QSum + outRng.Cells(jLoop, 1).Value WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value WSum2 = WSum2 + outRng.Cells(jLoop + 1, 3).Value WSum3 = WSum3 + outRng.Cells(jLoop + 2, 3).Value outRng.Rows(jLoop + 2).Delete outRng.Rows(jLoop + 1).Delete outRng.Rows(jLoop).Delete LastRow = LastRow - 3 Else ' check if bolts and washers are in reverse order If outRng.Cells(jLoop, 1) <> "" And _ outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _ outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 2, 2) And _ outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 1, 2) Then QSum = QSum + outRng.Cells(jLoop, 1).Value WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value WSum2 = WSum2 + outRng.Cells(jLoop + 2, 3).Value WSum3 = WSum3 + outRng.Cells(jLoop + 1, 3).Value outRng.Rows(jLoop + 2).Delete outRng.Rows(jLoop + 1).Delete outRng.Rows(jLoop).Delete LastRow = LastRow - 3 End If End If Next jLoop outRng.Cells(iLoop, 1).Value = QSum outRng.Cells(iLoop, 3).Value = WSum1 outRng.Cells(iLoop + 1, 3).Value = WSum2 outRng.Cells(iLoop + 2, 3).Value = WSum3 End If Next iLoop For iLoop = 1 To 3 outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth Next iLoop With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub 
  • Как найти дубликаты в столбце, прокручивая несколько листов
  • Поиск лучших индексов для объединения двух (или более) листов Excel
  • Excel: добавление одного поля повторяющихся строк и удаление повторяющихся строк
  • Удалите повторяющиеся строки, но сохраните данные в трех столбцах, используя Excel 2007
  • Как посмотреть предыдущий столбец при вставке данных
  • Удаление видимых дубликатов только видимых строк
  • Excel Список самых популярных номеров
  • Удалить дубликаты / дубликаты строк
  • Почему эта блокировка? Перебирайте все строки, выполняйте функцию по дублированию, удалите повторяющуюся строку
  • Excel VBA удаляет дубликаты, сохраняя позиционирование
  • Как удалить дубликаты в зависимости от значений в другом столбце (столбцах)?
  • Interesting Posts

    OpenPyXL с использованием встроенного условного форматирования, то есть: повторяющиеся и уникальные значения

    Импорт столбцов MS-Excel в MS-Word в виде комментариев

    Excel условный SUMPRODUCT / SUMIFS / Формула массива для дополнительного измерения

    Excel для сравнения двух диапазонов для идеального соответствия

    Динамические списки, зависящие от Excel, на основе имени учителя

    VBA, как скопировать подмножество строк из листа в другой

    Как я могу исправить ошибку подключения ODBC к базе данных при повторной загрузке моей книги?

    лучший контент о том, как развернуть и разделить решение VSTO

    Автоматическое начисление отсортированных номеров полей при вставке новой строки

    Excel, получить строковое значение в ячейке

    VBA Excel: Локальные переменные хранятся в памяти?

    Как настроить собственные имена заголовков с помощью ALASQL и XLSX

    как сопоставить столбцы в двух листах в excel

    Как назначить порядок сортировки в

    Код VBA для удаления диапазона на основе переменной – медленный запуск

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