Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Добавление артикулов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Добавление артикулов (Макросы/Sub)
Добавление артикулов
Oh_Nick Дата: Пятница, 13.10.2023, 09:53 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 426
Репутация: 8 ±
Замечаний: 20% ±

Excel 2019
Всем привет!

Подскажите, пожалуйста, с написанием макроса для добавления артикула с его номерами.
На листе Исходник мы заносим в колонку А артикул и справа пишем номера, после нажимаем кнопку и артикул с номерами переносится на лист результат. Лист Исходник будет заполняться постоянно, поэтому макрос должен учесть добавление новых артикулов к уже добавленным на лист Результат.
К сообщению приложен файл: artikul.xlsx (10.4 Kb)
 
Ответить
СообщениеВсем привет!

Подскажите, пожалуйста, с написанием макроса для добавления артикула с его номерами.
На листе Исходник мы заносим в колонку А артикул и справа пишем номера, после нажимаем кнопку и артикул с номерами переносится на лист результат. Лист Исходник будет заполняться постоянно, поэтому макрос должен учесть добавление новых артикулов к уже добавленным на лист Результат.

Автор - Oh_Nick
Дата добавления - 13.10.2023 в 09:53
jun Дата: Пятница, 13.10.2023, 11:09 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 38 ±
Замечаний: 0% ±

Добрый день!
Вариант:
[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: подразумевается, что связка артикул+номер - уникальное значение. Это очень ВАЖНО!
К сообщению приложен файл: artikul.xlsb (17.6 Kb)


Сообщение отредактировал jun - Пятница, 13.10.2023, 11:22
 
Ответить
СообщениеДобрый день!
Вариант:
[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
Дата добавления - 13.10.2023 в 11:09
Gustav Дата: Пятница, 13.10.2023, 11:26 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2578
Репутация: 1071 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Oh_Nick, а "Результат" можно каждый раз (при добавлении нового элемента) переписывать полностью? Или надо новые строчки в "Результате" вставлять между уже существующими, раздвигая существующие (т.е. вставлять в "Реультат" новые полные строки)? Т.е. предполагается ли добавлять в "Результат" какие-то новые данные в другие колонки (помимо A и B), привязываясь к конкретным строкам?


МОИ: Ник, Tip box: 41001663842605
 
Ответить
СообщениеOh_Nick, а "Результат" можно каждый раз (при добавлении нового элемента) переписывать полностью? Или надо новые строчки в "Результате" вставлять между уже существующими, раздвигая существующие (т.е. вставлять в "Реультат" новые полные строки)? Т.е. предполагается ли добавлять в "Результат" какие-то новые данные в другие колонки (помимо A и B), привязываясь к конкретным строкам?

Автор - Gustav
Дата добавления - 13.10.2023 в 11:26
Oh_Nick Дата: Пятница, 13.10.2023, 16:25 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 426
Репутация: 8 ±
Замечаний: 20% ±

Excel 2019
jun, супер!

А можно пожалуйста еще сделать так, чтобы сам артикул дублировался в колонке B? пример прикрепляю
К сообщению приложен файл: artikul_1.xlsb (18.2 Kb)
 
Ответить
Сообщениеjun, супер!

А можно пожалуйста еще сделать так, чтобы сам артикул дублировался в колонке B? пример прикрепляю

Автор - Oh_Nick
Дата добавления - 13.10.2023 в 16:25
jun Дата: Пятница, 13.10.2023, 17:14 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 38 ±
Замечаний: 0% ±

Подправил код. Тестируйте
К сообщению приложен файл: artikul_v0_1.xlsb (19.6 Kb)


Сообщение отредактировал jun - Суббота, 14.10.2023, 09:48
 
Ответить
СообщениеПодправил код. Тестируйте

Автор - jun
Дата добавления - 13.10.2023 в 17:14
Oh_Nick Дата: Пятница, 13.10.2023, 17:47 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 426
Репутация: 8 ±
Замечаний: 20% ±

Excel 2019
jun, спасибо огромное! последний нюанс:

а что можно сделать с такими кодами, которые на 00 например начинаются или на 0? Они перенеслись без 00...
К сообщению приложен файл: artikul_v0_1_2.xlsb (22.3 Kb)
 
Ответить
Сообщениеjun, спасибо огромное! последний нюанс:

а что можно сделать с такими кодами, которые на 00 например начинаются или на 0? Они перенеслись без 00...

Автор - Oh_Nick
Дата добавления - 13.10.2023 в 17:47
jun Дата: Пятница, 13.10.2023, 18:11 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 38 ±
Замечаний: 0% ±

Добавил в начало ключа одинарную кавычку (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]
К сообщению приложен файл: 2461464.xlsb (19.7 Kb)


Сообщение отредактировал jun - Суббота, 14.10.2023, 09:46
 
Ответить
СообщениеДобавил в начало ключа одинарную кавычку (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]

Автор - jun
Дата добавления - 13.10.2023 в 18:11
Oh_Nick Дата: Суббота, 14.10.2023, 01:35 | Сообщение № 8
Группа: Проверенные
Ранг: Обитатель
Сообщений: 426
Репутация: 8 ±
Замечаний: 20% ±

Excel 2019
jun, от души, спасибо hands
 
Ответить
Сообщениеjun, от души, спасибо hands

Автор - Oh_Nick
Дата добавления - 14.10.2023 в 01:35
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Добавление артикулов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2023 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!