Время от времени по вопросам из общей ветки вижу необходимость в подробном сравнении двух списков между собой с выводом отчёта, поэтому выкладываю свою версию на основе оригинальной идеи (откуда узнал именно я) BlackBox: Расширенное сравнение двух колонок (списков)
Модуль «MAIN» (основной)
Код
Option Explicit
'====================================================================================================================
Sub Сравнить2Списка() ' по мотивам BlackBox (http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/rasshirennoe_sravnenie_dvukh_kolonok/7-1-0-20)
Dim rng As Range, txtWB$
Dim dicUniq As Object, dicL As Object, dicR As Object
Dim x, arr1x(), arrOut(), txt$, r&
txtWB = ActiveWorkbook.FullName
Set rng = Selection
Set dicUniq = CreateObject("Scripting.Dictionary")
Set dicL = CreateObject("Scripting.Dictionary")
Set dicR = CreateObject("Scripting.Dictionary")
If Not FillDictisFromRange(rng, "для сравнения ПЕРВЫЙ (ЛЕВЫЙ) ДИАПАЗОН:", txtWB, dicUniq, dicL) Then Exit Sub
If Not FillDictisFromRange(rng, "для сравнения ВТОРОЙ (ПРАВЫЙ) ДИАПАЗОН:", txtWB, dicUniq, dicR) Then Exit Sub
If dicUniq.count = 0 Then MsgBox "Подходящие ключи не найдены!", vbInformation, "ПУСТО": Exit Sub
arr1x = dicUniq.Keys: Set dicUniq = Nothing
FILE_Sort_Array1x arr1x, 0, UBound(arr1x)
ReDim arrOut(1 To UBound(arr1x) + 2, 1 To 4)
arrOut(1, 1) = "КЛЮЧ"
arrOut(1, 2) = "СТАТУС КЛЮЧА"
arrOut(1, 3) = "СЛЕВА ключей"
arrOut(1, 4) = "СПРАВА ключей"
For r = 2 To UBound(arrOut, 1)
x = arr1x(r - 2): arrOut(r, 1) = x
If dicL.Exists(x) Then arrOut(r, 3) = dicL(x) Else arrOut(r, 3) = 0
If arrOut(r, 3) < 2 Then txt = "L" & arrOut(r, 3) Else txt = "Ln"
If dicR.Exists(x) Then arrOut(r, 4) = dicR(x) Else arrOut(r, 4) = 0
If arrOut(r, 4) < 2 Then txt = txt & "R" & arrOut(r, 4) Else txt = txt & "Rn"
arrOut(r, 2) = txt
Next r
Application.ScreenUpdating = False
Worksheets.Add , ActiveSheet
ActiveWindow.DisplayGridlines = False
Set rng = Cells(1, 1).Resize(UBound(arrOut, 1), UBound(arrOut, 2))
With rng
.Font.Name = "Times New Roman"
.Font.Size = 9
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.ShrinkToFit = True
End With
With rng.Rows(1)
.HorizontalAlignment = xlCenter
.Font.Bold = True
.WrapText = True
.ShrinkToFit = False
End With
rng.Borders.LineStyle = True
rng.Value2 = arrOut
ActiveSheet.ListObjects.Add xlSrcRange, rng, , xlYes
With Cells(2, 2).Resize(UBound(arrOut, 1), 3)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
Cells(1, 1).Resize(1, UBound(arrOut, 2)).ColumnWidth = 8
Cells(1, 1).Resize(1, UBound(arrOut, 2)).EntireColumn.AutoFit
If Columns(1).ColumnWidth > 100 Then Columns(1).ColumnWidth = 100
Application.ScreenUpdating = True
MsgBox "Успешно обработано и выявлено уникальных ключей: " & Format$(UBound(arrOut, 1) - 1, "# ##0"), vbInformation, ""
End Sub
'--------------------------------------------------------------------------------------------------------------------
Private Function FillDictisFromRange(ByVal rng As Range, ByVal txtHead$, ByVal txtWB$, dicU As Object, dicLR As Object) As Boolean
Dim ar As Range, arr, x, tmp, bt As Byte
rep: If Not FILE_SelectRange(rng, txtHead) Then Exit Function
If rng.Parent.Parent.FullName <> txtWB Then MsgBox "Оба диапазона для сравнения должны находиться в ОДНОЙ книге (одном файле)", vbCritical, "ОШИБКА ВЫДЕЛЕНИЯ": GoTo rep
Set rng = Intersect(rng, rng.Parent.UsedRange)
If FILE_HaveHide(rng) Then
bt = MsgBox("В выделенном диапазоне присутствуют СКРЫТЫЕ ячейки!" & vbLf & "Взять только ВИДИМЫЕ [ДА] или ВСЕ [НЕТ]?", vbYesNoCancel + vbQuestion + vbDefaultButton1)
If bt = vbCancel Then GoTo rep
If bt = vbYes Then
If Not FILE_GetVisible(rng, True) Then GoTo rep
End If
End If
If Not FILE_CheckRng(rng, True) Then GoTo rep
If FILE_IsRangeInUsed(rng, , True, True) <> 1 Then GoTo rep
If FILE_IsOneCellInRng(rng, True) Then GoTo rep
For Each ar In rng.Areas
arr = ar.Value2: If Not IsArray(arr) Then arr = Array(arr)
For Each x In arr
If IsError(x) Then MsgBox "В данных обнаружена ошибка!", vbCritical, "ОШИБКА ДАННЫХ": Exit Function
If Len(x) And x <> "—" Then tmp = dicU(x): dicLR(x) = dicLR(x) + 1
Next x
Next ar
FillDictisFromRange = True
End Function
'====================================================================================================================
Модуль «WORK» (вспомогательный)
Код
Option Explicit
Option Private Module
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Рекурсивный сортер 1x-массива в редакции от Anchoret: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=5&TID=114744&TITLE_SEO=114744-poluchenie-spiska-unikalnykh-znacheniy-iz-odnomernogo-massiva-vba&MID=953013&tags=%D0%9F%D0%BE%D0%BB%D1%83%D1%87%D0%B8%D1%82%D1%8C.%D0%B4%D0%B0%D0%BD%D0%BD%D1%8B%D0%B5.%D1%81%D0%B2%D0%BE%D0%B4%D0%BD%D0%BE%D0%B9+%D1%82%D0%B0%D0%B1%D0%BB%D0%B8%D1%86%D1%8B&_r=9788#message953013
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub FILE_Sort_Array1x(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FILE_Sort_Array1x arr1x, l, j
If i < u Then FILE_Sort_Array1x arr1x, i, u
End Sub
'====================================================================================================
Function FILE_SelectRange(rng As Range, Optional txtTitle$ = "ДИАПАЗОН") As Boolean
Dim cl As Range, SA As Boolean
SA = Application.ScreenUpdating: Application.ScreenUpdating = True
If rng Is Nothing Then Set rng = Selection
On Error Resume Next: Set cl = Application.InputBox("Выделите мышкой " & txtTitle, "ВЫДЕЛЕНИЕ ДИАПАЗОНА", Replace$(rng.Address, ",", ";"), Type:=8)
If Err.Number <> 0 Then GoTo fin Else On Error GoTo 0
Set rng = cl: FILE_SelectRange = True
fin: On Error GoTo 0: Application.ScreenUpdating = SA
End Function
'====================================================================================================
'====================================================================================================
Function FILE_CheckRangeFull(rng As Range, Optional MsgIfFalse As Boolean) As Boolean
If Not FILE_CheckRng(rng, MsgIfFalse) Then Exit Function
If FILE_HaveHide(rng, MsgIfFalse, False) Then Exit Function
If FILE_HaveMerge(rng, MsgIfFalse) Then Exit Function Else FILE_CheckRangeFull = True
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_CheckRng(rng As Range, Optional MsgIfFalse As Boolean) As Boolean
If TypeName(rng) <> "Range" Then GoTo er
If rng Is Nothing Then GoTo er
If rng.Cells.count < 1 Then GoTo er
If IsError(rng) Then GoTo er
If rng.Parent.ProtectContents = True Then GoTo er
FILE_CheckRng = True: Exit Function
er: If MsgIfFalse Then MsgBox "Диапазон некорректен!", vbCritical, "FILE_CheckRng"
End Function
'====================================================================================================
Function FILE_HaveHide(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If FILE_CountHide(rng) > 0 Then
FILE_HaveHide = True: If MsgIfTrue Then MsgBox "В диапазоне ПРИСУТСТВУЮТ СКРЫТЫЕ ячейки!", vbCritical, "FILE_HaveHide"
Else
If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ СКРЫТЫЕ ячейки!", vbCritical, "FILE_HaveHide"
End If
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_HaveVisible(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If rng.count > FILE_CountHide(rng) Then
FILE_HaveVisible = True: If MsgIfTrue Then MsgBox "В диапазоне ПРИСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_HaveVisible"
Else
If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_HaveVisible"
End If
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_CountHide(rng As Range) As Long
Dim vis&
If rng.count = 1 Then
If rng.EntireRow.Hidden Or rng.EntireColumn.Hidden Then FILE_CountHide = 1
Exit Function
End If
On Error Resume Next: FILE_CountHide = rng.count - rng.SpecialCells(xlCellTypeVisible).count: On Error GoTo 0
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_GetVisible(tmpRng As Range, Optional MsgIfFalse As Boolean) As Boolean
Dim vis&
If tmpRng.count = 1 Then
If tmpRng.EntireRow.Hidden Or tmpRng.EntireColumn.Hidden Then GoTo no Else GoTo yes
End If
On Error Resume Next: vis = tmpRng.SpecialCells(xlCellTypeVisible).count: On Error GoTo 0: If vis = 0 Then GoTo no
Set tmpRng = tmpRng.SpecialCells(xlCellTypeVisible)
yes: FILE_GetVisible = True: Exit Function
no: If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_GetVisible"
End Function
'====================================================================================================
Function FILE_HaveMerge(rng As Range, Optional MsgIfTrue As Boolean) As Boolean
If rng.MergeCells = False Then Exit Function Else FILE_HaveMerge = True
If MsgIfTrue Then MsgBox "В диапазоне присутствуют ОБЪЕДИНЁННЫЕ ячейки!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'====================================================================================================
Function FILE_IsOneAreaInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If rng.Areas.count = 1 Then
FILE_IsOneAreaInRng = True: If MsgIfTrue Then MsgBox "Диапазон содержит ОДНУ область!", vbCritical, "ОШИБКА ДИАПАЗОНА"
Else
If MsgIfFalse Then MsgBox "Диапазон содержит БОЛЕЕ ОДНОЙ области!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End If
End Function
'-------------------------------------------------------------------------------------------
Function FILE_IsOneCellInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If rng.Cells.count = 1 Then FILE_IsOneCellInRng = True Else GoTo ex
If MsgIfTrue Then MsgBox "Не менее ДВУХ ячеек!", vbCritical, "ОШИБКА ДИАПАЗОНА": Exit Function Else Exit Function
ex: If MsgIfFalse Then MsgBox "Не более ОДНОЙ ячейки!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'-------------------------------------------------------------------------------------------
Function FILE_IsOneColumnInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
Dim ar As Range, cl As Range, col&
col = rng.Cells(1, 1).Column
For Each ar In rng.Areas
If ar.Cells(1, 1).Column <> col Or ar.Columns.count <> 1 Then
If MsgIfFalse Then MsgBox "Диапазон содержит более ОДНОГО столбца!", vbCritical, "ОШИБКА ДИАПАЗОНА"
Exit Function
End If
Next ar
FILE_IsOneColumnInRng = True: If MsgIfTrue Then MsgBox "Диапазон должен содержать более ОДНОГО столбца!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'====================================================================================================
Function FILE_IsRangeInUsed(tmpRng As Range, Optional MsgIfFull As Boolean, Optional MsgIfPart As Boolean, Optional MsgIfOut As Boolean) As Integer ' -1 = полностью снаружи, 0 = пересекается, 1 = полностью внутри
Dim rngU As Range, rngI As Range
FILE_IsRangeInUsed = -1
Set rngU = tmpRng.Parent.UsedRange
Set rngI = Intersect(tmpRng, rngU)
If rngI Is Nothing Then
Set tmpRng = rngU
If MsgIfOut Then MsgBox "Выделенный диапазон ЦЕЛИКОМ СНАРУЖИ рабочей области листа!", vbExclamation, "FILE_IsRangeInUsed"
ElseIf rngI.Address = tmpRng.Address Then
FILE_IsRangeInUsed = 1
If MsgIfFull Then MsgBox "Выделенный диапазон ЦЕЛИКОМ ВНУТРИ рабочей области листа!", vbExclamation, "FILE_IsRangeInUsed"
Else
FILE_IsRangeInUsed = 0
Set tmpRng = rngI
If MsgIfPart Then MsgBox "Выделенный диапазон ЧАСТИЧНО СОВПАДАЕТ с рабочей областью листа!", vbExclamation, "FILE_IsRangeInUsed"
End If
End Function
'====================================================================================================
Скрины
• поддерживает предварительное выделение для первого списка • поддерживает выделение столбцов целиком (обрезает до рабочей области) • поддерживает работу со скрытыми строками (учитывает только видимые или игнорирует фильтр) • прочие проверки
ПЛЮСЫ: • в десятки раз быстрее BlackBox на больших объёмах • нет классов, для работы нужно всего 2 модуля («WORK» нужен для проверок, сортировки и диалоговых окон выделения диапазона)
МИНУСЫ: • нет заливки (замедляет выполнение и легко сделать самому по фильтрам, если очень надо)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Что-то при сравнении происходит разрыв шаблона. Я думаю обычный пользователь вообще не поймёт чего получилось. Какие-то ключи, непонятные буквы, обозначение которых надо сначала понять. Я так понимаю надо просто сравнить два диапазона. Ну, так и надо тогда написать в выводе что совпало и что осталось в первом и во втором диапазонах. А тут если честно взрыв мозга. Зачем так усложнять. Или я что-то не понял по ходу.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Alemox: обычный пользователь вообще не поймёт чего получилось
если непонятно, то всегда можно спросить)))
Что обычно (лично мне, во всяком случае) нужно понять при сравнении двух списков? • получить список значений из обоих столбцов/списков (круто, если он будет отсортирован) • указать, какое значение, из какого списка (назначить тип) • указать сколько таких значений в обоих списках Всё это макрос успешно выполняет
На практике: • вытаскиваю из смет материалы и оборудование, формируя из них уникальный список • отправляю его в снабжение для получения рыночных цен • получаю обратно частично заполненный от них список и сопоставляю через этот макрос с образцом За время заполнения некоторые наименования и/или единицы измерений могли поменяться — я это сразу увижу в отчёте
Короче говоря, лично мне идея и принцип BlackBox очень понравился и оказался весьма полезен
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
потому что опять это не вопрос, а готовое решение и в ветке с вопросами ему делать нечего, как по мне… Можно в Копилку, но там даже Виталий редкий гость - куда уж мне
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Evgenyy: Не сочтите за обиду, но я абсолютно согласен с Alemox
да на что мне обижаться — что вам оказалось не полезно? Думаю, что вы далеко не первые и уж точно не последние Моё дело поделиться вариантом
У меня часто многотысячные списки, которые могут отличаться одной строкой, а могут тысячами Эта штука мне сразу на эти вопросы быстро и подробненько отвечает
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Evgenyy, не вижу ничего сложного, ну правда — пару раз сделать и всё понятно будет Можно, конечно писать вместо L1Rn —> в списке, который вы выделили первым содежится ОДНО такое значение, а в правом НЕСКОЛЬКО, но по такой логике можно все условные обозначения заменять полными наименованиями
Что именно сложно? Я не вижу ничего лишнего (группировку LEFT/BOTH/RIGHT убрал т.к. лично мне достаточно одного столбца со статусами, в фильтре которого будет не более 8ми значений)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
а описание для кого?))) L1R1 — это обычное условное обозначение, существенно сокращающее запись без потери информации
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Я вообще никого обидеть не хотел. Jack Famous, объяснил на своём примере, я понял для чего это. Но, лично в моём варианте так не получится. Всё что нам шлют в ответку это сканы в PDF и там вообще без шансов использовать Excel .
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
если вы про меня, то не вижу причин для обиды)) Только понять не могу, что там мудрёного — уникальный список из элементов обоих исходных списков, который отсортирован и указано, какой элемент, в каком из исходных списков присутствует и в каком количестве + для облегчения анализа и фильтрации введено 8 условных обозначений (по мне - примитивных и интуитивно понятных)
Цитата
Alemox: Всё что нам шлют в ответку это сканы в PDF
сочувствую - знаком с таким…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Выкладываю вторую версию, в которой добавлен столбец с ГРУППОЙ (где найдено) и "переведены" статусы
Названия столбцов, групп (где найдено) и статусов (L0Rn) легко редактируются в коде
Модуль «MAIN» (изменился)
Код
Option Explicit
'====================================================================================================================
Sub Сравнить2Списка() ' по мотивам BlackBox (http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/rasshirennoe_sravnenie_dvukh_kolonok/7-1-0-20)
Dim rng As Range, txtWB$
Dim dicUniq As Object, dicL As Object, dicR As Object
Dim x, arr1x(), arrOut(), txt$, r&
txtWB = ActiveWorkbook.FullName
Set dicUniq = CreateObject("Scripting.Dictionary")
Set dicL = CreateObject("Scripting.Dictionary")
Set dicR = CreateObject("Scripting.Dictionary")
Set rng = Selection: If Not FillDictisFromRange(rng, "для сравнения ПЕРВЫЙ (ЛЕВЫЙ) ДИАПАЗОН:", txtWB, dicUniq, dicL) Then Exit Sub
Set rng = Nothing: If Not FillDictisFromRange(rng, "для сравнения ВТОРОЙ (ПРАВЫЙ) ДИАПАЗОН:", txtWB, dicUniq, dicR) Then Exit Sub
If dicUniq.count = 0 Then MsgBox "Подходящие ключи не найдены!", vbInformation, "ПУСТО": Exit Sub
arr1x = dicUniq.Keys: Set dicUniq = Nothing
FILE_Sort_Array1x arr1x, 0, UBound(arr1x)
ReDim arrOut(1 To UBound(arr1x) + 2, 1 To 5)
arrOut(1, 1) = "ЗНАЧЕНИЕ"
arrOut(1, 2) = "ГДЕ НАЙДЕНО"
arrOut(1, 3) = "СТАТУС"
arrOut(1, 4) = "СКОЛЬКО СЛЕВА"
arrOut(1, 5) = "СКОЛЬКО СПРАВА"
For r = 2 To UBound(arrOut, 1)
x = arr1x(r - 2): arrOut(r, 1) = x
If dicL.Exists(x) Then arrOut(r, 4) = dicL(x) Else arrOut(r, 4) = 0
If arrOut(r, 4) < 2 Then txt = "Л" & arrOut(r, 4) Else txt = "Лн"
If dicR.Exists(x) Then arrOut(r, 5) = dicR(x) Else arrOut(r, 5) = 0
If arrOut(r, 5) < 2 Then txt = txt & "П" & arrOut(r, 5) Else txt = txt & "Пн"
arrOut(r, 3) = txt
If Mid$(txt, 2, 1) = "0" Then
arrOut(r, 2) = "только СПРАВА"
Else
If Right$(txt, 1) = "0" Then
arrOut(r, 2) = "только СЛЕВА"
Else
arrOut(r, 2) = "в ОБОИХ"
End If
End If
Next r
Application.ScreenUpdating = False
Worksheets.Add , ActiveSheet
ActiveWindow.DisplayGridlines = False
Set rng = Cells(1, 1).Resize(UBound(arrOut, 1), UBound(arrOut, 2))
With rng
.Font.Name = "Times New Roman"
.Font.Size = 9
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.ShrinkToFit = True
End With
With rng.Rows(1)
.HorizontalAlignment = xlCenter
.Font.Bold = True
.WrapText = True
.ShrinkToFit = False
End With
rng.Borders.LineStyle = True
rng.Value2 = arrOut
ActiveSheet.ListObjects.Add xlSrcRange, rng, , xlYes
rng.AutoFilter
With Cells(2, 2).Resize(UBound(arrOut, 1), UBound(arrOut, 2) - 1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
Cells(1, 1).Resize(1, UBound(arrOut, 2)).ColumnWidth = 10
Cells(1, 1).Resize(1, UBound(arrOut, 2)).EntireColumn.AutoFit
If Columns(1).ColumnWidth > 100 Then Columns(1).ColumnWidth = 100
Application.ScreenUpdating = True
MsgBox "Успешно обработано и выявлено уникальных ключей: " & Format$(UBound(arrOut, 1) - 1, "# ##0"), vbInformation, ""
End Sub
'--------------------------------------------------------------------------------------------------------------------
Private Function FillDictisFromRange(ByVal rng As Range, ByVal txtHead$, ByVal txtWB$, dicU As Object, dicLR As Object) As Boolean
Dim ar As Range, arr, x, tmp, bt As Byte
rep: If Not FILE_SelectRange(rng, txtHead) Then Exit Function
If rng.Parent.Parent.FullName <> txtWB Then MsgBox "Оба диапазона для сравнения должны находиться в ОДНОЙ книге (одном файле)", vbCritical, "ОШИБКА ВЫДЕЛЕНИЯ": GoTo rep
Set rng = Intersect(rng, rng.Parent.UsedRange)
If FILE_HaveHide(rng) Then
bt = MsgBox("В выделенном диапазоне присутствуют СКРЫТЫЕ ячейки!" & vbLf & "Взять только ВИДИМЫЕ [ДА] или ВСЕ [НЕТ]?", vbYesNoCancel + vbQuestion + vbDefaultButton1)
If bt = vbCancel Then GoTo rep
If bt = vbYes Then
If Not FILE_GetVisible(rng, True) Then GoTo rep
End If
End If
If Not FILE_CheckRng(rng, True) Then GoTo rep
If FILE_IsRangeInUsed(rng, , True, True) <> 1 Then GoTo rep
If FILE_IsOneCellInRng(rng, True) Then GoTo rep
For Each ar In rng.Areas
arr = ar.Value2: If Not IsArray(arr) Then arr = Array(arr)
For Each x In arr
If IsError(x) Then MsgBox "В данных обнаружена ошибка!", vbCritical, "ОШИБКА ДАННЫХ": Exit Function
If Len(x) And x <> "—" Then tmp = dicU(x): dicLR(x) = dicLR(x) + 1
Next x
Next ar
FillDictisFromRange = True
End Function
Модуль «WORK» (не изменился)
Код
Option Explicit
Option Private Module
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Рекурсивный сортер 1x-массива в редакции от Anchoret: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=5&TID=114744&TITLE_SEO=114744-poluchenie-spiska-unikalnykh-znacheniy-iz-odnomernogo-massiva-vba&MID=953013&tags=%D0%9F%D0%BE%D0%BB%D1%83%D1%87%D0%B8%D1%82%D1%8C.%D0%B4%D0%B0%D0%BD%D0%BD%D1%8B%D0%B5.%D1%81%D0%B2%D0%BE%D0%B4%D0%BD%D0%BE%D0%B9+%D1%82%D0%B0%D0%B1%D0%BB%D0%B8%D1%86%D1%8B&_r=9788#message953013
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub FILE_Sort_Array1x(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FILE_Sort_Array1x arr1x, l, j
If i < u Then FILE_Sort_Array1x arr1x, i, u
End Sub
'====================================================================================================
Function FILE_SelectRange(rng As Range, Optional txtTitle$ = "ДИАПАЗОН") As Boolean
Dim cl As Range, SA As Boolean
SA = Application.ScreenUpdating: Application.ScreenUpdating = True
If rng Is Nothing Then Set rng = Selection
On Error Resume Next: Set cl = Application.InputBox("Выделите мышкой " & txtTitle, "ВЫДЕЛЕНИЕ ДИАПАЗОНА", Replace$(rng.Address, ",", ";"), Type:=8)
If Err.Number <> 0 Then GoTo fin Else On Error GoTo 0
Set rng = cl: FILE_SelectRange = True
fin: On Error GoTo 0: Application.ScreenUpdating = SA
End Function
'====================================================================================================
'====================================================================================================
Function FILE_CheckRangeFull(rng As Range, Optional MsgIfFalse As Boolean) As Boolean
If Not FILE_CheckRng(rng, MsgIfFalse) Then Exit Function
If FILE_HaveHide(rng, MsgIfFalse, False) Then Exit Function
If FILE_HaveMerge(rng, MsgIfFalse) Then Exit Function Else FILE_CheckRangeFull = True
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_CheckRng(rng As Range, Optional MsgIfFalse As Boolean) As Boolean
If TypeName(rng) <> "Range" Then GoTo er
If rng Is Nothing Then GoTo er
If rng.Cells.count < 1 Then GoTo er
If IsError(rng) Then GoTo er
If rng.Parent.ProtectContents = True Then GoTo er
FILE_CheckRng = True: Exit Function
er: If MsgIfFalse Then MsgBox "Диапазон некорректен!", vbCritical, "FILE_CheckRng"
End Function
'====================================================================================================
Function FILE_HaveHide(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If FILE_CountHide(rng) > 0 Then
FILE_HaveHide = True: If MsgIfTrue Then MsgBox "В диапазоне ПРИСУТСТВУЮТ СКРЫТЫЕ ячейки!", vbCritical, "FILE_HaveHide"
Else
If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ СКРЫТЫЕ ячейки!", vbCritical, "FILE_HaveHide"
End If
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_HaveVisible(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If rng.count > FILE_CountHide(rng) Then
FILE_HaveVisible = True: If MsgIfTrue Then MsgBox "В диапазоне ПРИСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_HaveVisible"
Else
If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_HaveVisible"
End If
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_CountHide(rng As Range) As Long
Dim vis&
If rng.count = 1 Then
If rng.EntireRow.Hidden Or rng.EntireColumn.Hidden Then FILE_CountHide = 1
Exit Function
End If
On Error Resume Next: FILE_CountHide = rng.count - rng.SpecialCells(xlCellTypeVisible).count: On Error GoTo 0
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_GetVisible(tmpRng As Range, Optional MsgIfFalse As Boolean) As Boolean
Dim vis&
If tmpRng.count = 1 Then
If tmpRng.EntireRow.Hidden Or tmpRng.EntireColumn.Hidden Then GoTo no Else GoTo yes
End If
On Error Resume Next: vis = tmpRng.SpecialCells(xlCellTypeVisible).count: On Error GoTo 0: If vis = 0 Then GoTo no
Set tmpRng = tmpRng.SpecialCells(xlCellTypeVisible)
yes: FILE_GetVisible = True: Exit Function
no: If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_GetVisible"
End Function
'====================================================================================================
Function FILE_HaveMerge(rng As Range, Optional MsgIfTrue As Boolean) As Boolean
If rng.MergeCells = False Then Exit Function Else FILE_HaveMerge = True
If MsgIfTrue Then MsgBox "В диапазоне присутствуют ОБЪЕДИНЁННЫЕ ячейки!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'====================================================================================================
Function FILE_IsOneAreaInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If rng.Areas.count = 1 Then
FILE_IsOneAreaInRng = True: If MsgIfTrue Then MsgBox "Диапазон содержит ОДНУ область!", vbCritical, "ОШИБКА ДИАПАЗОНА"
Else
If MsgIfFalse Then MsgBox "Диапазон содержит БОЛЕЕ ОДНОЙ области!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End If
End Function
'-------------------------------------------------------------------------------------------
Function FILE_IsOneCellInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If rng.Cells.count = 1 Then FILE_IsOneCellInRng = True Else GoTo ex
If MsgIfTrue Then MsgBox "Не менее ДВУХ ячеек!", vbCritical, "ОШИБКА ДИАПАЗОНА": Exit Function Else Exit Function
ex: If MsgIfFalse Then MsgBox "Не более ОДНОЙ ячейки!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'-------------------------------------------------------------------------------------------
Function FILE_IsOneColumnInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
Dim ar As Range, cl As Range, col&
col = rng.Cells(1, 1).Column
For Each ar In rng.Areas
If ar.Cells(1, 1).Column <> col Or ar.Columns.count <> 1 Then
If MsgIfFalse Then MsgBox "Диапазон содержит более ОДНОГО столбца!", vbCritical, "ОШИБКА ДИАПАЗОНА"
Exit Function
End If
Next ar
FILE_IsOneColumnInRng = True: If MsgIfTrue Then MsgBox "Диапазон должен содержать более ОДНОГО столбца!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'====================================================================================================
Function FILE_IsRangeInUsed(tmpRng As Range, Optional MsgIfFull As Boolean, Optional MsgIfPart As Boolean, Optional MsgIfOut As Boolean) As Integer ' -1 = полностью снаружи, 0 = пересекается, 1 = полностью внутри
Dim rngU As Range, rngI As Range
FILE_IsRangeInUsed = -1
Set rngU = tmpRng.Parent.UsedRange
Set rngI = Intersect(tmpRng, rngU)
If rngI Is Nothing Then
Set tmpRng = rngU
If MsgIfOut Then MsgBox "Выделенный диапазон ЦЕЛИКОМ СНАРУЖИ рабочей области листа!", vbExclamation, "FILE_IsRangeInUsed"
ElseIf rngI.Address = tmpRng.Address Then
FILE_IsRangeInUsed = 1
If MsgIfFull Then MsgBox "Выделенный диапазон ЦЕЛИКОМ ВНУТРИ рабочей области листа!", vbExclamation, "FILE_IsRangeInUsed"
Else
FILE_IsRangeInUsed = 0
Set tmpRng = rngI
If MsgIfPart Then MsgBox "Выделенный диапазон ЧАСТИЧНО СОВПАДАЕТ с рабочей областью листа!", vbExclamation, "FILE_IsRangeInUsed"
End If
End Function
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Alemox написал: Всё что нам шлют в ответку это сканы в PDF
Ах, по живому резанул! Похоже подобные нелюди везде окопались. В моём случае гады сначала ПЕЧАТАЮТ всё на бумаге, подписывают (а как-же без подписи шариковой ручкой в России?!), потом сканируют в PDF и присылают нам в "электронном виде" (так они это называют). Причём нечётные стороны сканированы нормально, а чётные стороны - вверх ногами. И вот в подобной "радости" мне надо "выщемить" свои строки, которых может и не оказаться.
Цитата
Jack Famous написал: Расширенное сравнение двух колонок (списков)
Забрал для дальнейшего изучения и потребления, в хозяйстве всё сгодится.