Подскажите, пожалуйста, с написанием макроса для добавления артикула с его номерами. На листе Исходник мы заносим в колонку А артикул и справа пишем номера, после нажимаем кнопку и артикул с номерами переносится на лист результат. Лист Исходник будет заполняться постоянно, поэтому макрос должен учесть добавление новых артикулов к уже добавленным на лист Результат.
Всем привет!
Подскажите, пожалуйста, с написанием макроса для добавления артикула с его номерами. На листе Исходник мы заносим в колонку А артикул и справа пишем номера, после нажимаем кнопку и артикул с номерами переносится на лист результат. Лист Исходник будет заполняться постоянно, поэтому макрос должен учесть добавление новых артикулов к уже добавленным на лист Результат.Oh_Nick
Sub articule() Dim exists_dict As Object, not_exists_dict As Object, key As Variant Dim arr As Variant, j As Long, i As Long, lr As Long ' создаем словари Set exists_dict = CreateObject("Scripting.Dictionary") Set not_exists_dict = CreateObject("Scripting.Dictionary")
' записываем значения с листа Исходник в массив и загружаем в словарь With Worksheets("Исходник") arr = .Cells(2, 1).CurrentRegion For i = 2 To UBound(arr, 1) ' 2 - потому, что игнорируем первую строку с заголовком For j = 2 To UBound(arr, 2) ' если значение ячейки d j столбце не пусто то: If arr(i, j) <> "" Then not_exists_dict(arr(i, 1) & ":" & arr(i, j)) = "" Next j Next i End With
With Worksheets("Результат") lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце arr = .Range("A2:B" & lr) ' загружаем значения в массив ' загружаем значения из массива в словарь For i = LBound(arr, 1) To UBound(arr, 1) exists_dict(arr(i, 1) & ":" & arr(i, 2)) = "" Next i 'проверяем есть ли совпадения ключей из словаря not_exists_dict в exists_dict на листе Результат For Each key In not_exists_dict.keys() If Not exists_dict.exists(key) Then ' если совпадений нет, то: arr = Split(key, ":") ' создаем массив, разбивая значение ключа по : lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце .Cells(lr + 1, 1).Resize(1, UBound(arr) + 1) = arr ' записываем в первую непустую строку значение массива arr End If Next key End With End Sub
[/vba]
P.S: подразумевается, что связка артикул+номер - уникальное значение. Это очень ВАЖНО!
Добрый день! Вариант: [vba]
Код
Sub articule() Dim exists_dict As Object, not_exists_dict As Object, key As Variant Dim arr As Variant, j As Long, i As Long, lr As Long ' создаем словари Set exists_dict = CreateObject("Scripting.Dictionary") Set not_exists_dict = CreateObject("Scripting.Dictionary")
' записываем значения с листа Исходник в массив и загружаем в словарь With Worksheets("Исходник") arr = .Cells(2, 1).CurrentRegion For i = 2 To UBound(arr, 1) ' 2 - потому, что игнорируем первую строку с заголовком For j = 2 To UBound(arr, 2) ' если значение ячейки d j столбце не пусто то: If arr(i, j) <> "" Then not_exists_dict(arr(i, 1) & ":" & arr(i, j)) = "" Next j Next i End With
With Worksheets("Результат") lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце arr = .Range("A2:B" & lr) ' загружаем значения в массив ' загружаем значения из массива в словарь For i = LBound(arr, 1) To UBound(arr, 1) exists_dict(arr(i, 1) & ":" & arr(i, 2)) = "" Next i 'проверяем есть ли совпадения ключей из словаря not_exists_dict в exists_dict на листе Результат For Each key In not_exists_dict.keys() If Not exists_dict.exists(key) Then ' если совпадений нет, то: arr = Split(key, ":") ' создаем массив, разбивая значение ключа по : lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце .Cells(lr + 1, 1).Resize(1, UBound(arr) + 1) = arr ' записываем в первую непустую строку значение массива arr End If Next key End With End Sub
[/vba]
P.S: подразумевается, что связка артикул+номер - уникальное значение. Это очень ВАЖНО!jun
Oh_Nick, а "Результат" можно каждый раз (при добавлении нового элемента) переписывать полностью? Или надо новые строчки в "Результате" вставлять между уже существующими, раздвигая существующие (т.е. вставлять в "Реультат" новые полные строки)? Т.е. предполагается ли добавлять в "Результат" какие-то новые данные в другие колонки (помимо A и B), привязываясь к конкретным строкам?
Oh_Nick, а "Результат" можно каждый раз (при добавлении нового элемента) переписывать полностью? Или надо новые строчки в "Результате" вставлять между уже существующими, раздвигая существующие (т.е. вставлять в "Реультат" новые полные строки)? Т.е. предполагается ли добавлять в "Результат" какие-то новые данные в другие колонки (помимо A и B), привязываясь к конкретным строкам?Gustav
Добавил в начало ключа одинарную кавычку (14.10 внес правки в код; код ниже - уже исправленный вариант) Код: [vba]
Код
Sub articule() Dim exists_dict As Object, not_exists_dict As Object, key As Variant Dim arr As Variant, j As Long, i As Long, lr As Long, flag As Boolean, str As String
' создаем словари Set exists_dict = CreateObject("Scripting.Dictionary") Set not_exists_dict = CreateObject("Scripting.Dictionary")
' записываем значения с листа Исходник в массив и загружаем в словарь With Worksheets("Исходник") arr = .Cells(2, 1).CurrentRegion For i = 2 To UBound(arr, 1) ' 2 - потому, что игнорируем первую строку с заголовком For j = 2 To UBound(arr, 2) ' если значение ячейки d j столбце не пусто то: If arr(i, j) <> "" Then not_exists_dict("'" & arr(i, 1) & ":" & arr(i, j)) = "" Next j Next i End With
With Worksheets("Результат") lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце arr = .Range("A2:B" & lr) ' загружаем значения в массив ' загружаем значения из массива в словарь For i = LBound(arr, 1) To UBound(arr, 1) If arr(i, 1) <> arr(i, 2) Then exists_dict("'" & arr(i, 1) & ":" & arr(i, 2)) = "" Next i
flag = True str = Split(not_exists_dict.keys()(1), ":")(0)
'проверяем есть ли совпадения ключей из словаря not_exists_dict в exists_dict на листе Результат For Each key In not_exists_dict.keys() If Not exists_dict.exists(key) Then ' если совпадений нет, то: arr = Split(key, ":") lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце If str <> arr(0) Then flag = True If flag Then .Cells(lr + 1, 1).Resize(1, 2) = arr(0) str = arr(0): flag = False: lr = lr + 1 End If .Cells(lr + 1, 1).Resize(1, UBound(arr) + 1) = arr ' записываем в первую непустую строку значение массива arr End If Next key End With End Sub
[/vba]
Добавил в начало ключа одинарную кавычку (14.10 внес правки в код; код ниже - уже исправленный вариант) Код: [vba]
Код
Sub articule() Dim exists_dict As Object, not_exists_dict As Object, key As Variant Dim arr As Variant, j As Long, i As Long, lr As Long, flag As Boolean, str As String
' создаем словари Set exists_dict = CreateObject("Scripting.Dictionary") Set not_exists_dict = CreateObject("Scripting.Dictionary")
' записываем значения с листа Исходник в массив и загружаем в словарь With Worksheets("Исходник") arr = .Cells(2, 1).CurrentRegion For i = 2 To UBound(arr, 1) ' 2 - потому, что игнорируем первую строку с заголовком For j = 2 To UBound(arr, 2) ' если значение ячейки d j столбце не пусто то: If arr(i, j) <> "" Then not_exists_dict("'" & arr(i, 1) & ":" & arr(i, j)) = "" Next j Next i End With
With Worksheets("Результат") lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце arr = .Range("A2:B" & lr) ' загружаем значения в массив ' загружаем значения из массива в словарь For i = LBound(arr, 1) To UBound(arr, 1) If arr(i, 1) <> arr(i, 2) Then exists_dict("'" & arr(i, 1) & ":" & arr(i, 2)) = "" Next i
flag = True str = Split(not_exists_dict.keys()(1), ":")(0)
'проверяем есть ли совпадения ключей из словаря not_exists_dict в exists_dict на листе Результат For Each key In not_exists_dict.keys() If Not exists_dict.exists(key) Then ' если совпадений нет, то: arr = Split(key, ":") lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце If str <> arr(0) Then flag = True If flag Then .Cells(lr + 1, 1).Resize(1, 2) = arr(0) str = arr(0): flag = False: lr = lr + 1 End If .Cells(lr + 1, 1).Resize(1, UBound(arr) + 1) = arr ' записываем в первую непустую строку значение массива arr End If Next key End With End Sub