Не совсем понял, куда пропало мое сообщение... Дублирую Уважаемые форумчане! Прошу помощи вот в таком вопросе. Есть файл https://yadi.sk/d/XbjB8sE9f8qkBQ. Сжать его меньше 100 Кб никак не получается. В нем на каждом листе есть артикулы. Мне надо выделить те, что повторяются на разных листах. Методы из похожей темы пробовал - не подошли. Помогите, пожалуйста.
Наиболее близким к тому, что нужно, является этот скрипт
Код
Sub ColorsDoubles() On Error Resume Next
' массив цветов, используемых для заливки ячеек-дубликатов
Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)
Dim coll As New Collection, dupes As New Collection, _
cols As New Collection, ra As Range, cell As Range, n&
Err.Clear: Set ra = Intersect(Selection, ActiveSheet.UsedRange)
If Err Then Exit Sub
ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes
Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
Next cell
For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов
n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
Next
For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет
cell.Interior.Color = cols(CStr(cell.Value)) ' если надо окрасить всю строку,то cell.EntireRow.Interior.color = cols(CStr(cell.Value))
Next cell
Application.ScreenUpdating = True
End Sub
Но он действует только в рамках одного листа и выделенного диапазона ячеек.
Я попробовал распространить его на всю книгу
Код
Sub ColorsDoubles()
On Error Resume Next
' массив цветов, используемых для заливки ячеек-дубликатов
Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)
Dim coll As New Collection, dupes As New Collection, _
cols As New Collection, ra As Range, cell As Range, n&
For Each oneSheet In ThisWorkbook.Sheets
Err.Clear: Set ra = worksheet.UsedRange
Next
If Err Then Exit Sub
ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes
Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
Next cell
For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов
n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
Next
For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет
cell.Interior.Color = cols(CStr(cell.Value)) ' если надо окрасить всю строку,то cell.EntireRow.Interior.color = cols(CStr(cell.Value))
Next cell
Application.ScreenUpdating = True End Sub
Но в итоге все окрасило одним цветом по непонятному мне принципу https://yadi.sk/i/vt7kK9hJN7e5Pg . Я ошибся или пошел не тем путем?
San Tut, а нужно искать во всех ячейках или определенном столбце - предположил что берем только значения столбца E:E
Код
Sub mrshkei()
Dim arr, arr2, i As Long, lr As Long, sh As Worksheet, sh2 As Worksheet, cell As Range, rng As Range, cell2 As Range
For Each sh In Worksheets
lr = sh.Cells(Rows.Count, 5).End(xlUp).Row
arr = sh.Range("E2:E" & lr)
For i = LBound(arr) To UBound(arr)
For Each sh2 In Worksheets
k = Application.WorksheetFunction.CountIfs(sh2.Columns(5), arr(i, 1))
If k > 1 And sh.Name = sh2.Name Then
Set rng = sh2.Range("E2:E" & sh2.Cells(Rows.Count, 5).End(xlUp).Row)
For Each cell In rng
If cell = arr(i, 1) Then cell.Interior.ColorIndex = 3
Next cell
ElseIf k = 1 And sh.Name <> sh2.Name Then
Set cell2 = sh2.Columns(5).Find(arr(i, 1))
cell2.Interior.ColorIndex = 3
End If
Next sh2
Next i
Next sh
End Sub
По логике - если на 1 листе у ТС все работает как надо и вопрос стоит только почему это не работает по циклу по листам.... то вопрос: а что выполняется в цикле по листам?
Разберитесь для начала с этим:
Код
For Each oneSheet In ThisWorkbook.Sheets
Err.Clear: Set ra = worksheet.UsedRange
Next
Marat Ta написал: А зачем нам все 750 кб ваших данных?Для файла-примера хватило бы и части данных.
К сожалению, то, что работает на части данных не сработало на целом файле. Я пробовал решения из аналогичной темы. На файлах-примерах все работало, а применимо к этому файлу - нет. К тому же, один раз меня тут уже отчитали за то, что не прилагаю конкретные примеры
Mershik , интересный вариант, спасибо, завтра на работе попробую. Я же правильно понимаю, что чтобы изменить столбец, например, на B, нужно E:E заменить на B:B и 5 везде заменить на 2?
Цитата
Marat Ta написал: По логике - если на 1 листе у ТС все работает как надо и вопрос стоит только почему это не работает по циклу по листам.... то вопрос: а что выполняется в цикле по листам?
По логике - да. Но есть опасения, что в этом как раз ошибка, что алгоритм работает каждый раз в рамках итерации, а не сравнивает листы между собой. А вот как его изменить, чтобы он начал сравнивать листы между собой и почему он все красит в один-два цвета - до этого я додуматься пока что не могу.
Я вам выделил участок вашего кода с циклом, где ясно что проход по листам пустышка. Простейшая задача (используя коллекцию или словарь), учитесь применять поиск на форуме.
смысла в использовании разных цветов не вижу. каков он? Ну я б еще понял что заливка соответствовала б цвету листа на котором дубликат, а если он на нескольких листах? 1. на сервисный лист копируем со всех листов артикулы в один столбец, желательно собирая массив из диапазонов по листам. 2. Включаем штатный УФ и помечаем дубликаты. 3. Фильтруем по цвету и и помечаем дубликаты каким либо образом. 4. Снимаем фильтр 5. Переносим на исходные данные пометки используя ранее сохраненные диапазоны 6. убираем сервисный лист.
писать некогда , да и в отведенные мной 10 срок не поместится, но мне кажется будет очень шустро.
Marat Ta написал: учитесь применять поиск на форуме.
Не знаю, с чем это связано, но у меня форум с рабочего компа как-то неправильно работает. Мне приходится по 10 раз редактировать сообщения, т.к. при публикации они или исчезают, как было с первым сообщением темы, или изменяются до неузнаваемости.Комп проверял всем чем только можно - никакого результата. С другими сайтами все в порядке. А тема, указанная Вами, мне не попадалась, хоть я и искал. За ссылку большое спасибо - изучу.
Цитата
БМВ написал: смысла в использовании разных цветов не вижу. каков он? Ну я б еще понял что заливка соответствовала б цвету листа на котором дубликат, а если он на нескольких листах?
Смысл в том, чтобы каждый артикул имел свой цвет и было видно сколько раз повторяется именно он. Иначе ребятки мои тратят очень много времени на выискивание дубликатов вручную, а им за это никто не платит. Не для себя стараюсь. А мысль тоже интересная, спасибо
San Tut, как вариант получать список дубликатов на отдельном листе с указанием артикула и листов на которых находятся дубликаты и возможно сразу ссылку на них для быстрого перехода.
Цитата
Только один лист выпадает из общей канвы. Если я ставлю E:F, то на что заменить 5?
Скорее всего нужно писать уже не columns(5) а columns("E:F"), но это лучше конкретизировать что где и скорее всего придётся переделывать макрос.
Mershik написал: Смысл в том, чтобы каждый артикул имел свой цвет и было видно сколько раз повторяется именно он.
бред ибо разбросанные цветовые пометки по листам - попробуй найди. Тогда уж проще формировать реестр повторений с указанием где найдено. А уж делать быстрый переход или нет - это вопрос второй.
Да, действительно, если заменить, то выдает ошибку.
Цитата
Mershik написал: получать список дубликатов на отдельном листе
Вы о чем-то типа этого?
Код
Sub FindDuplicates()
Dim Dict As Object, aa As Range, arr()
Set Dict = CreateObject("Scripting.Dictionary")
For Each aa In Sheets(1).UsedRange
If Len(aa.Value) > 0 Then
If Not Dict.exists(aa.Value) Then
Dict.Add aa.Value, 1
Else
Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
End If
End If
Next
On Error Resume Next
Set aa = Application.InputBox("Select distination cell.", , , , , , , 8)
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End Sub
Он тоже ищет только на одном листе. Есть другой вариант, но в нем ошибка. Но я никак не могу понять где конкретно.
Код
Sub FindDuplicates()
' Declare Current as a worksheet object variable.
Dim Current As Worksheet
Dim Dict As Object, aa As Range, arr()
Set Dict = CreateObject("Scripting.Dictionary")
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
For Each aa In Sheets(1).Range("H2:I60000") '[H2:I60000]
If aa <> "Сводная" Then
If Len(aa.Value) > 0 Then
If Not Dict.exists(aa.Value) Then
Dict.Add aa.Value, 1
Else
Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
End If
End If
End If
Next
Next
On Error Resume Next
Set aa = Application.InputBox("Select distination cell.", , , , , , , 8)
If aa <> "Сводная" Then
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End If
End Sub
Есть подсказка, что ошибка потому что словарь получается пустой. Чтоб его заполнить - нужно не только перебирать листы, но и их ячейки. И приведена строка
Код
For Each aa In Current.Range("H2:I60000")
Но я что-то никак не могу додуматься, куда эту строку запихнуть. Как мартышка с очками.
Marat Ta, спасибо, ни разу не пользовался этим форматом, буду знать.
Так, решение практически найдено вот тут, спасибо, опять же, Вам. Вот оно:
Код
Sub FindDuplicates()
' Declare ws as a worksheet object variable.
Dim ws As Worksheet
Dim Dict As Object, aa As Range, arr()
Set Dict = CreateObject("Scripting.Dictionary")
' Loop through all of the worksheets in the active workbook.
For Each ws In Worksheets
For Each aa In ws.Range("H2:I60000") ' <= 2. здесь был жестко прописан Sheets(1). , замененный на ws.
If aa <> "Сводная" Then
If Len(aa.Value) > 0 Then
If Not Dict.exists(aa.Value) Then
Dict.Add aa.Value, 1
Else
Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
End If
End If
End If
Next
Next
On Error Resume Next
Set aa = Application.InputBox("Выберите ячейку для вывода результата", , , , , , , 8)
If aa <> "Сводная" Then
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys) ' <= 1. здесь приводилась ошибка пустого словаря
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End If
End Sub
Теперь осталось сообразить, как в
Код
For Each aa In ws.Range("H2:I60000")
заменить диапазон "H2:I60000" на переменную и дело сделано (ведь те, кто будет этим пользоваться, макросы только в кошмарах видели). В данный момент курю форумы и мануалы на эту тему. Пока не догоняю. Если кто может указать мне, где я не прав и что с этим делать, то было бы супер.
Пока застрял вот на этом:
Код
Sub FindDuplicates()
' Declare ws as a worksheet object variable.
Dim ws As Worksheet
Dim Dict As Object, aa As Range, arr()
Dim myRange As Range
Set Dict = CreateObject("Scripting.Dictionary")
Set myRange = Application.InputBox("Выберите исследуемый диапазон", , , , , , , 8)
' Loop through all of the worksheets in the active workbook.
For Each ws In Worksheets
For Each aa In ws.Range(myRange) ' <= вот тут ошибка. Что я делаю не так?
If aa <> "Сводная" Then
If Len(aa.Value) > 0 Then
If Not Dict.exists(aa.Value) Then
Dict.Add aa.Value, 1
Else
Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
End If
End If
End If
Next
Next
On Error Resume Next
Set aa = Application.InputBox("Выберите ячейку для вывода результата", , , , , , , 8)
If aa <> "Сводная" Then
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys) ' <= 1. здесь приводилась ошибка пустого словаря
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End If
End Sub
Дебаг вылетает в строке 12. Если может кто посоветовать литературу по теме (желательно бумажную), чтобы подтянуть теорию, отдельное спасибо.
Kuzmich написал: Из правил форума2.3. Приложите файл(ы) с примером (общим весом не более 300Кб) в реальной структуре
Я прошу прощения, но мне незачем сочинять. Я очень уважаю этот форум и его участников. Возможно, в выведенном сообщении ошибка. Как я писал ранее, на рабочем компе форум иногда работает неправильно.
Изменено: San Tut - 30.04.2021 18:00:00(Перезалил скриншот)
Замените Cells(1,1) на свою стартовую ячейку на всех листах. И создайте лист "Дубликаты".
Код
Sub prDublicat()
Dim sh As Worksheet
Dim Dd As Object
Dim t$, i&, j&, b$
Set Dd = CreateObject("scripting.dictionary")
With CreateObject("scripting.dictionary"): .comparemode = 1
For Each sh In ActiveWorkbook.Sheets
sh.Activate
Cells.Interior.Color = xlNone
If sh.Name = "Дубликаты" Then GoTo SledSh
a = Cells(1, 1).Resize(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)
For i = 1 To UBound(a)
For j = 1 To UBound(a, 2)
If IsEmpty(a(i, j)) Then GoTo SledA
t = CStr(a(i, j))
If .exists(t) Then
If .Item(t) <> "" Then
s = Split(.Item(t))
Sheets(s(0)).Cells(Val(s(1)), Val(s(2))).Interior.Color = vbRed
End If
sh.Cells(i, j).Interior.Color = vbRed
b = .Item(t) & ";" & sh.Name & " " & i & " " & j
.Item(t) = ""
If Dd.exists(t) Then b = Dd.Item(t) & ";" & b
Dd.Item(t) = b
Else
.Item(t) = sh.Name & " " & i & " " & j
End If
SledA: Next
Next
SledSh: Next
End With
Sheets("Дубликаты").Activate
If Dd.Count > 0 Then Cells(1).Resize(Dd.Count, 2) = Application.Transpose(Array(Dd.keys, Dd.items))
End Sub
Marat Ta, спасибо, но в этом варианте как-то много лишнего выделилось (файл прилагаю) В этом документе по сути не так много дубликатов. Скорее всего, вот они: 5012-1 5012-2 5012-3 5012-5 5012-6 5012-7 84214-3 84217-2 84217-5 84202-1 84202-14
Судя по всему, Ваш вариант берет еще графу с компаньонами. В случае выделения одним цветом всех дубликатов получается, что дубликатами являются практически все артикулы. Тут или разные цвета или выбор проверяемых столбцов.
в доп.лист собрать в колонки А - значение дубликат В - имя 1-го листа С - имя 2-го листа Д - есть еще дубли? имя следующего листа .... каждое из значений в колонках В, С, Д и далее - это не просто имя листа - это гиперссылка на соотв. ячейку указанного листа, которая содержит дубликат в итоге: 1. весь отчет о дублях на одном листе, 2. каждый дубль легко посмотреть одним кликом 3. не нужно ячейки на листах раскрашивать в попугайские цвета, не нужно нарушать стилистику листов
Marat Ta, артикулы могут быть в произвольных колонках в рамках определенного диапазона, как и компаньоны.По первоначальной задумке, каждый артикул, встречающийся более 1 раза должен был быть подсвечен своим уникальным цветом, чтобы его сразу было видно. Но, если это труднореализуемо, то спасет и информация о дублях артикулов как на разных листах, так и на одном. Но именно артикулов, а не компаньонов или артикулов и компаньонов. И тут как раз требуется выделить диапазон в 2-3-4 столбца, в зависимости от того, как они гуляют в очередной выгрузке поставщика. Пользоваться этим решением будут люди, для которых Excel - это если не программа для рисования табличек, то что-то около того. Им нужно показать какую кнопку нажимать и что писать.
Вот список дублей по артикулам, собранный с помощью PLEX (лицензия, последняя версия) и условного форматирования
Скрытый текст
5012-1
5012-2
5012-3
5012-5
5012-6
5012-6
5012-7
84214-3
84214-3
84217-2
84217-5
84217-5
84217-2
84202-1
84202-14
84202-14
84202-1
5012-1
5012-2
5012-3
5012-5
5012-6
5012-7
Каюсь, пятница, вечер, голова не варит, могу и тупить. Вернусь к размышлениям во вторник, 4-го (да, меня внезапные выходные не касаются). Всем хороших праздников!
Kuzmich, а у меня получилось 935. Файл прилагаю. В файле есть скрипт, которым считал. Это почти то, что нужно, за исключением жестко прописанного диапазона, который я хотел бы заменить на переменную, но никак не могу додуматься как.
Ігор Гончаренко, рад видеть Вас в добром здравии! Как раз и делаем примерно то, что Вы описали.
Если вы на всех листах в строке 1 напишите слово Артикул, там где у вас действительно артикулы, то тогда и меня получилось 935
Цитата
за исключением жестко прописанного диапазона, который я хотел бы заменить на переменную
В стандартный модуль, запускать при активном листе Дубликаты
Код
Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr
Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
For Each Sht In Worksheets
If Sht.Name <> "Дубликаты" Then
With Sht
Set FoundCell = .Rows(1).Find("Артикул", , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
ColArticul = FoundCell.Column
iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
For i = 1 To UBound(arr)
dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
Next
End If
Set FoundCell = Nothing
End With
End If
Next
Columns("C:D").ClearContents
Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub
Kuzmich, да, пожалуй, это выход. Огромное спасибо! Я позволил себе добавить небольшую вишенку на торт в виде создания листа.
Код
Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr
ThisWorkbook.Sheets.Add.Name = "Дубликаты"
Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
For Each Sht In Worksheets
If Sht.Name <> "Дубликаты" Then
With Sht
Set FoundCell = .Rows(1).Find("Артикул", , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
ColArticul = FoundCell.Column
iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
For i = 1 To UBound(arr)
dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
Next
End If
Set FoundCell = Nothing
End With
End If
Next
Columns("C:D").ClearContents
Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub
Вот если б можно было бы название столбца сделать не жестко прописанным в код, а как-то так:
Код
Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr
Dim Col As Variant
Set Col = Application.InputBox("Укажите название столбца", , , , , , , 2)
ThisWorkbook.Sheets.Add.Name = "Дубликаты"
Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
For Each Sht In Worksheets
If Sht.Name <> "Дубликаты" Then
With Sht
Set FoundCell = .Rows(1).Find("Col", , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
ColArticul = FoundCell.Column
iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
For i = 1 To UBound(arr)
dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
Next
End If
Set FoundCell = Nothing
End With
End If
Next
Columns("C:D").ClearContents
Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub
Но этот вариант не взлетел. Если подскажете, где я ошибся, буду благодарен. А так, предложенный Вами вариант в большинстве случаев уже спасет.
Kuzmich, оу, прошу прощение, раскладка глюканула. Столбец может называться не "Артикул", а "Номенклатура". Я пытаюсь сделать так, чтобы пользователь сам определял область поиска или название столбца, в котором программа будет искать.
Код
...
Dim Col As Variant ' Создаем переменную, которой присвоим значение - имя столбца (заголовок)
Set Col = Application.InputBox("Укажите название столбца", , , , , , , 2) ' Запрашиваем у пользователя имя столбца (заголовок) и заключаем его в переменную Col
ThisWorkbook.Sheets.Add.Name = "Дубликаты" ' Создаем лист для вывода
Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
For Each Sht In Worksheets
If Sht.Name <> "Дубликаты" Then
With Sht
Set FoundCell = .Rows(1).Find(Col, , xlValues, xlWhole) 'Подставляем переменную вместо слова "Артикул"
...
чтобы пользователь сам определял область поиска или название столбца, в котором программа будет искать
Я бы добавил в макрос проверку наличия листа Дубликаты, если вы при каждом запуске макроса создаете такой лист. Также нужна проверка наличия заголовка (Артикул или Номенклатура) на очередном листе и выдача сообщения об отсутствии оного, так как столбцы с артикулами у вас предполагаются на каждом листе, а вот заголовки на некоторых листах отсутствовали.
Цитата
Application.InputBox("Укажите название столбца", , , , , , , 2)