Как разнести заказы клиентов в один общий столбец

[Hugo121]

Я только за

[staniiislav]

Сообщение от Hugo121

Я только за

я вот немного подумал, как такой вариант?

Option Explicit


Sub Niki12()
Dim a(), b(), i&, n&, t, lr&, dic1 As Object, dic2 As Object
If MsgBox("Произвести поиск?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
a = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
b = Range("D2:E" & Cells(Rows.Count, "D").End(xlUp).Row).Value
'ReDim c(1 To UBound(a), 1 To 1)
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row).ClearContents

    For i = 1 To UBound(b): dic1.Item(b(i, 1)) = i: Next i
    For i = 1 To UBound(a): dic2.Item(a(i, 1)) = i: Next i
    For i = 1 To UBound(a)
        If dic1.exists(a(i, 1)) Then
            t = dic1.Item(a(i, 1))
            If IsEmpty(a(i, 2)) Then a(i, 2) = b(t, 2) Else a(i, 2) = a(i, 2) & ", " & b(t, 2)
        End If
    Next i
    For i = 1 To UBound(b)
        If Not dic2.exists(b(i, 1)) Then n = n + 1: b(n, 1) = b(i, 1): b(n, 2) = b(i, 2)
    Next i
Range("H2").Resize(UBound(a), 2).Value = a
With Sheets("Нет в прайсе")
    lr = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    .Range("A" & lr).Resize(n, 2) = b
    .Range("C" & lr & ":" & "C" & .Cells(Rows.Count, "A").End(xlUp).Row) = Application.UserName
    .Range("D" & lr & ":" & "D" & .Cells(Rows.Count, "A").End(xlUp).Row) = Now
End With
MsgBox "Поиск завершен.", vbInformation, "Поиск"
End Sub

[Hugo121]

Некогда сейчас писать свой вариант (да и надоело слегка ), но есть пока 2 замечания:
1. Тогда нужно бы сперва взять в словарь/массив с листа "Нет в прайсе" и дополнять его, иначе там могут нарасти повторы.
2. Я специально разбил исходные данные на 2 массива - чтоб не выгружать назад столбец "Прайс", а только товары. Но это несущественно - так, экономия ресурсов...

[staniiislav]

Сообщение от Hugo121

Некогда сейчас писать свой вариант (да и надоело слегка ), но есть пока 2 замечания:
1. Тогда нужно бы сперва взять в словарь/массив с листа "Нет в прайсе" и дополнять его, иначе там могут нарасти повторы.
2. Я специально разбил исходные данные на 2 массива - чтоб не выгружать назад столбец "Прайс", а только товары. Но это несущественно - так, экономия ресурсов...

завтра подумаем, но в моем примере, за-то могут повторы быть по столбцу А ))) (которых в принципе не должно быть ))))

[staniiislav]

ну вот как-то так :

Option Explicit


Sub Niki12()
Dim a(), b(), c(), d(), e(), f()
Dim i&, n&, t, lr&, dic1 As Object, dic2 As Object, dic3 As Object, tm
'If MsgBox("Произвести поиск?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
tm = Timer
a = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
b = Range("D2:E" & Cells(Rows.Count, "D").End(xlUp).Row).Value
c = Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
d = Sheets("Нет в прайсе").Range("A2:A" & Sheets("Нет в прайсе").Cells(Rows.Count, "A").End(xlUp).Row).Value
f = Sheets("Нет в прайсе").Range("B2:B" & Sheets("Нет в прайсе").Cells(Rows.Count, "A").End(xlUp).Row).Value
ReDim e(1 To UBound(b), 1 To 2)
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dic3 = CreateObject("scripting.dictionary")
dic1.comparemode = 1
dic2.comparemode = 1
dic3.comparemode = 1
Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row).ClearContents

    For i = 1 To UBound(b): dic1.Item(b(i, 1)) = i: Next i
    For i = 1 To UBound(a): dic2.Item(a(i, 1)) = i: Next i
    For i = 1 To UBound(d): dic3.Item(d(i, 1)) = i: Next i
    For i = 1 To UBound(a)
        If dic1.exists(a(i, 1)) Then
            t = dic1.Item(a(i, 1))
            If IsEmpty(c(i, 1)) Then c(i, 1) = b(t, 2) Else c(i, 1) = c(i, 1) & ", " & b(t, 2)
        End If
    Next i
    For i = 1 To UBound(b)
        If Not dic2.exists(b(i, 1)) Then
            If dic3.exists(b(i, 1)) Then
                t = dic3.Item(b(i, 1))
                If IsEmpty(f(t, 1)) Then f(t, 1) = b(i, 2) Else f(t, 1) = f(t, 1) & ", " & b(i, 2)
            Else
                n = n + 1: e(n, 1) = b(i, 1): e(n, 2) = b(i, 2)
            End If
        End If
    Next i
Range("H2").Resize(UBound(c)).Value = c
With Sheets("Нет в прайсе")
    .Range("B2").Resize(UBound(f)).Value = f
    If n Then
        lr = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
        .Range("A" & lr).Resize(n, 2) = e
        '.Range("C" & lr & ":" & "C" & .Cells(Rows.Count, "A").End(xlUp).Row) = Application.UserName
        '.Range("D" & lr & ":" & "D" & .Cells(Rows.Count, "A").End(xlUp).Row) = Now
    End If
End With
'MsgBox "Поиск завершен.", vbInformation, "Поиск"
Debug.Print Timer - tm
End Sub

[Niki12]

Ув. staniiislav! Спасибо за Вашу доработку! Теперь на отдельный лист вместе с перечнем несуществующих в прайсе товаров вносится и имя компа, и время работы,очень удобно! Правда, чтобы это заработало,пришлось удалить из кода Hugo121 строки
With Workbooks.Add.Worksheets(1)
.Range("A1").Resize(ndic.Count) = Application.Transpose(ndic.keys)
.Range("B1").Resize(ndic.Count) = Application.Transpose(ndic.items)
End With
Кстати,насчет повторов в листе "Нет в прайсе" мне тоже до лампочки, его ведь тоже можно отсортировать и посмотреть,этот список мне нужен исключительно для общего сведения. Ваш последний вариант кода из поста 25 я тоже попробовала,но он,если был товар не из прайса в предыдущем заказе, и потом в последующем, к сожалению не работает,пока не удалишь внесенную строку в листе "Нет в прайсе".
Уважаемые Hugo121 и staniiislav! Благодаря Вам я уже получила код,который меня абсолютно устраивает! Моей душеньке и желать более нечего! Как я хотела, так макрос и работает! Огромное Вам спасибо! Хотя мне очень интересно, до какого еще более совершенного варианта Вы додумаетесь в своем соревновании! Ребята,я вас люблю! Обязательно еще зайду и посмотрю,чем же все-таки дело кончится! А пока еще раз благодарю Вас за помощь! С уважением Ники.

[Hugo121]

Да в общем мы не соревнуемся
Я просто упростил, и блох выискиваю.
Вот одну поймал в последнем коде Станислава: если допустим в заказе
товар12 маг2-7кг
а в прайсах есть
товар12 маг1-8кг
товар12 маг3-8кг
то результат
товар12 маг1-8кг, маг2-7кг
товар12 маг3-8кг, маг2-7кг
что думаю неправильно.
Всёж я думаю что сперва нужно в прайсах убрать дубли отдельной процедурой или как угодно, ну а потом уже несложным кодом подтягивать новые заказы и отбирать в сторону те, что нет в прайсах.
А то этот последний код такой навороченный, что мне и вникать неохота

[staniiislav]

Сообщение от Niki12

Ваш последний вариант кода из поста 25 я тоже попробовала,но он,если был товар не из прайса в предыдущем заказе, и потом в последующем, к сожалению не работает,пока не удалишь внесенную строку в листе "Нет в прайсе".

просто если в листе "Нет в прайсе" уже есть такой товар, он просто дополняется. Это было сделано, чтобы можно было избежать повторов. Это легко подправить, на последний макрос Hugo121 для Вас подойдет лучше...

[staniiislav]

Сообщение от Hugo121

Да в общем мы не соревнуемся
Я просто упростил, и блох выискиваю.
Вот одну поймал в последнем коде Станислава: если допустим в заказе
товар12 маг2-7кг
а в прайсах есть
товар12 маг1-8кг
товар12 маг3-8кг
то результат
товар12 маг1-8кг, маг2-7кг
товар12 маг3-8кг, маг2-7кг
что думаю неправильно.
Всёж я думаю что сперва нужно в прайсах убрать дубли отдельной процедурой или как угодно, ну а потом уже несложным кодом подтягивать новые заказы и отбирать в сторону те, что нет в прайсах.
А то этот последний код такой навороченный, что мне и вникать неохота

наверное вы правы... я стремился добавлять если есть дубликаты в столбце А, но наверное это не правильно )))
Вообщем мой последний код нужно полностью пересмотреть ))))

[staniiislav]

не а каком соперничестве и речи не может быть! Я только учусь, а Hugo121 профи!