Как разнести заказы клиентов в один общий столбец - Microsoft Office Excel - Страница 2

Niki12 · 05.03.2013, 06:00

Уважаемые Hugo121 и staniiislav! Огромное спасибо за отклик! Код,предложенный в посте №4,меня очень устроил! Работает! Ситуация,когда магазин заказывает товар не из прайса,действительно часто бывает,если бы макрос выводил список таких товаров,было бы просто супер! Но и без этого я Вам безмерно благодарна! Но если Вы имеете желание в коде что-то подправить,я думаю,вопрос "Произвести поиск" наверное не нужен,ведь и так понятно,что для этого-то макрос и запускают.Еще раз огромное-преогромное спасибо!!!!!

Hugo121 · 05.03.2013, 10:26

Код:

Sub Niki12()
    Dim a(), b(), c(), il&, i&, t&, ndic As Object
    il = Cells(Rows.Count, "A").End(xlUp).Row
    a = Range("A2:A" & il).Value    'где ищем
    b = Range("B2:B" & il).Value    'что будем пополнять
    c = Range("D2:E" & Cells(Rows.Count, "D").End(xlUp).Row).Value    'что ищем, чем пополняем
    Set ndic = CreateObject("scripting.dictionary")
    ndic.comparemode = 1

    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(a): .Item(a(i, 1)) = i: Next i

        For i = 1 To UBound(c)
            If .exists(c(i, 1)) Then    'если есть в прайсе
                t = .Item(c(i, 1))
                If Len(b(t, 1)) Then b(t, 1) = b(t, 1) & ", " & c(i, 2) Else b(t, 1) = c(i, 2)
            Else    'если нет в прайсе
                If ndic.exists(c(i, 1)) Then    'если уже отобрано
                    ndic.Item(c(i, 1)) = ndic.Item(c(i, 1)) & ", " & c(i, 2)
                Else    'если первый раз встретилось
                    ndic.Item(c(i, 1)) = c(i, 2)
                End If
            End If
        Next i
    End With

    'тут выгружаем назад в B2, но сейчас для теста в H2
    Range("H2").Resize(UBound(b)).Value = b

    'для отсутствующих в прайсе
    If ndic.Count > 0 Then
        'можно выгрузить под прайс
        If ndic.Count > 0 Then
            Range("A" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.keys)
            Range("B" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.items)
        End If

        'или создаём новую книгу
        'из неё копипастьте куда угодно
        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
    End If


    MsgBox "Поиск завершён.", vbInformation, "Поиск"
End Sub

staniiislav · 05.03.2013, 11:16

Цитата:

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

Код:

Sub Niki12()
    Dim a(), b(), c(), il&, i&, t&, ndic As Object
    il = Cells(Rows.Count, "A").End(xlUp).Row
    a = Range("A2:A" & il).Value    'где ищем
    b = Range("B2:B" & il).Value    'что будем пополнять
    c = Range("D2:E" & Cells(Rows.Count, "D").End(xlUp).Row).Value    'что ищем, чем пополняем
    Set ndic = CreateObject("scripting.dictionary")
    ndic.comparemode = 1

    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(a): .Item(a(i, 1)) = i: Next i

        For i = 1 To UBound(c)
            If .exists(c(i, 1)) Then    'если есть в прайсе
                t = .Item(c(i, 1))
                If Len(b(t, 1)) Then b(t, 1) = b(t, 1) & ", " & c(i, 2) Else b(t, 1) = c(i, 2)
            Else    'если нет в прайсе
                If ndic.exists(c(i, 1)) Then    'если уже отобрано
                    ndic.Item(c(i, 1)) = ndic.Item(c(i, 1)) & ", " & c(i, 2)
                Else    'если первый раз встретилось
                    ndic.Item(c(i, 1)) = c(i, 2)
                End If
            End If
        Next i
    End With

    'тут выгружаем назад в B2, но сейчас для теста в H2
    Range("H2").Resize(UBound(b)).Value = b

    'для отсутствующих в прайсе
    If ndic.Count > 0 Then
        'можно выгрузить под прайс
        If ndic.Count > 0 Then
            Range("A" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.keys)
            Range("B" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.items)
        End If

        'или создаём новую книгу
        'из неё копипастьте куда угодно
        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
    End If


    MsgBox "Поиск завершён.", vbInformation, "Поиск"
End Sub

а как быть с повторами в данном случаи?

Hugo121 · 05.03.2013, 11:35

Повторы обрабатываются. Там есть комментарий.

staniiislav · 05.03.2013, 11:50

Цитата:

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

Повторы обрабатываются. Там есть комментарий.

а подскажите пожалуйста, если в столбце а тоже будут повторы, как их учесть, они же в словарь не добавятся?

Hugo121 · 05.03.2013, 12:12

За эти повторы я не отвечаю

- их просто не должно быть (по логике процесса).
Симитировал - в такой товар новые заказы дописываются в последнюю строку, т.к. именно её координаты запоминаются в словаре.
Но если там могут проскочить повторы из-за ошибок оператора - думаю их нужно выявить/устранить отдельной процедурой. В любое время.

Усложнять этот код думаю нет смысла (к тому же в реальном файле наверняка могут быть ещё другие осложнения).
Но вообще сделать можно - сперва проверяем прайс на повторы, собираем "идеальный" массив данных, его выгружаем на лист вместо исходного (затираем/очищаем исходный диапазон - ведь строк станет меньше), затем отрабатывает существующий код.
Или всё можно соединить в один алгоритм, но зачем ломать голову

staniiislav · 05.03.2013, 12:20

Цитата:

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

За эти повторы я не отвечаю

- их просто не должно быть (по логике процесса).
Симитировал - в такой товар новые заказы дописываются в последнюю строку, т.к. именно её координаты запоминаются в словаре.
Но если там могут проскочить повторы из-за ошибок оператора - думаю их нужно выявить/устранить отдельной процедурой. В любое время.

Усложнять этот код думаю нет смысла (к тому же в реальном файле наверняка могут быть ещё другие осложнения).
Но вообще сделать можно - сперва проверяем прайс на повторы, собираем "идеальный" массив данных, его выгружаем на лист вместо исходного (затираем/очищаем исходный диапазон - ведь строк станет меньше), затем отрабатывает существующий код.
Или всё можно соединить в один алгоритм, но зачем ломать голову

в принципе все понятно. Спасибо за ответ

Niki12 · 05.03.2013, 16:21

Ув. Hugo121! Спасибо,что Вы доработали код.Из него я,правда,удалила
If ndic.Count > 0 Then
Range("A" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.keys)
Range("B" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.items)
End If
т.к. добавлять несуществующий товар в конец прайса мне не нужно.
Ув.Hugo121! Раз уж пошла такая песня,может подумаете над таким моментом. После того,как я, т.е. макрос :-) внесет заказы в прайс от одного магазина, я удаляю этот заказ и копирую заказ следующего магазина,дальше снова запускаю макрос и т.д. Но вот несуществующие в прайсе товары,заказанные разными магазинами, каждый раз заносятся в новую книгу, это возможно,чтобы они добавлялись в одну книгу,а лучше, в другой лист книги с прайсом, в один список друг под другом и назвать его,например,"Нет в прайсе". Что касается повторов в прайсе,они мне не страшны,прайс у меня всегда отсортирован,заказы будут рядом,их всегда можно будет заметить. Еще раз Вам спасибо за помощь.

staniiislav · 05.03.2013, 17:17

Цитата:

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

Ув. Hugo121! Спасибо,что Вы доработали код.Из него я,правда,удалила
If ndic.Count > 0 Then
Range("A" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.keys)
Range("B" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.items)
End If
т.к. добавлять несуществующий товар в конец прайса мне не нужно.
Ув.Hugo121! Раз уж пошла такая песня,может подумаете над таким моментом. После того,как я, т.е. макрос :-) внесет заказы в прайс от одного магазина, я удаляю этот заказ и копирую заказ следующего магазина,дальше снова запускаю макрос и т.д. Но вот несуществующие в прайсе товары,заказанные разными магазинами, каждый раз заносятся в новую книгу, это возможно,чтобы они добавлялись в одну книгу,а лучше, в другой лист книги с прайсом, в один список друг под другом и назвать его,например,"Нет в прайсе". Что касается повторов в прайсе,они мне не страшны,прайс у меня всегда отсортирован,заказы будут рядом,их всегда можно будет заметить. Еще раз Вам спасибо за помощь.

надеюсь Hugo121 будет не против, если я подправлю данный код

Код:

Option Explicit

Sub Niki12()
    Dim a(), b(), c(), il&, i&, t&, ndic As Object, tm, lr&
    If MsgBox("Произвести поиск?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    tm = Timer
    Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row).ClearContents
    il = Cells(Rows.Count, "A").End(xlUp).Row
    a = Range("A2:A" & il).Value    'где ищем
    b = Range("B2:B" & il).Value    'что будем пополнять
    c = Range("D2:E" & Cells(Rows.Count, "D").End(xlUp).Row).Value    'что ищем, чем пополняем
    Set ndic = CreateObject("scripting.dictionary")
    ndic.comparemode = 1

    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(a): .Item(a(i, 1)) = i: Next i

        For i = 1 To UBound(c)
            If .exists(c(i, 1)) Then    'если есть в прайсе
                t = .Item(c(i, 1))
                If Len(b(t, 1)) Then b(t, 1) = b(t, 1) & ", " & c(i, 2) Else b(t, 1) = c(i, 2)
            Else    'если нет в прайсе
                If ndic.exists(c(i, 1)) Then    'если уже отобрано
                    ndic.Item(c(i, 1)) = ndic.Item(c(i, 1)) & ", " & c(i, 2)
                Else    'если первый раз встретилось
                    ndic.Item(c(i, 1)) = c(i, 2)
                End If
            End If
        Next i
    End With

    'тут выгружаем назад в B2, но сейчас для теста в H2
    Range("H2").Resize(UBound(b)).Value = b

    'для отсутствующих в прайсе
    If ndic.Count > 0 Then
        'можно выгрузить под прайс
        'If ndic.Count > 0 Then
        '    Range("A" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.keys)
        '    Range("B" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.items)
        'End If

        'или создаём новую книгу
        'из неё копипастьте куда угодно
        '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
        With Sheets("Нет в прайсе")
            lr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Range("A" & lr).Resize(ndic.Count) = Application.Transpose(ndic.keys)
            .Range("B" & lr).Resize(ndic.Count) = Application.Transpose(ndic.items)
        End With
    End If
Debug.Print Timer - tm

    MsgBox "Поиск завершён.", vbInformation, "Поиск"
End Sub

НО лист "Нет в прайсе" должен обязательно существать

staniiislav · 05.03.2013, 17:38

Цитата:

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

With Sheets("Нет в прайсе")
lr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & lr).Resize(ndic.Count) = Application.Transpose(ndic.keys)
.Range("B" & lr).Resize(ndic.Count) = Application.Transpose(ndic.items)
End With

а можно и вот это добавить для удобства:

Код:

With Sheets("Нет в прайсе")
            lr = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
            .Range("A" & lr).Resize(ndic.Count) = Application.Transpose(ndic.keys)
            .Range("C" & lr & ":" & "C" & .Cells(.Rows.Count, "A").End(xlUp).Row) = Application.UserName
            .Range("B" & lr).Resize(ndic.Count) = Application.Transpose(ndic.items)
            .Range("D" & lr & ":" & "D" & .Cells(.Rows.Count, "A").End(xlUp).Row) = Now
            
        End With

05.03.2013, 11:35	#14
Hugo121 Старожил Регистрация: 11.05.2010 Сообщений: 5,166	Повторы обрабатываются. Там есть комментарий. webmoney: E265281470651 Z422237915069 R418926282008

05.03.2013, 12:12	#16
Hugo121 Старожил Регистрация: 11.05.2010 Сообщений: 5,166	За эти повторы я не отвечаю - их просто не должно быть (по логике процесса). Симитировал - в такой товар новые заказы дописываются в последнюю строку, т.к. именно её координаты запоминаются в словаре. Но если там могут проскочить повторы из-за ошибок оператора - думаю их нужно выявить/устранить отдельной процедурой. В любое время. Усложнять этот код думаю нет смысла (к тому же в реальном файле наверняка могут быть ещё другие осложнения). Но вообще сделать можно - сперва проверяем прайс на повторы, собираем "идеальный" массив данных, его выгружаем на лист вместо исходного (затираем/очищаем исходный диапазон - ведь строк станет меньше), затем отрабатывает существующий код. Или всё можно соединить в один алгоритм, но зачем ломать голову webmoney: E265281470651 Z422237915069 R418926282008 Последний раз редактировалось Hugo121; 05.03.2013 в 12:17.

05.03.2013, 16:21	#18
Niki12 Регистрация: 13.05.2012 Сообщений: 9	Ув. Hugo121! Спасибо,что Вы доработали код.Из него я,правда,удалила If ndic.Count > 0 Then Range("A" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.keys) Range("B" & il + 1).Resize(ndic.Count) = Application.Transpose(ndic.items) End If т.к. добавлять несуществующий товар в конец прайса мне не нужно. Ув.Hugo121! Раз уж пошла такая песня,может подумаете над таким моментом. После того,как я, т.е. макрос :-) внесет заказы в прайс от одного магазина, я удаляю этот заказ и копирую заказ следующего магазина,дальше снова запускаю макрос и т.д. Но вот несуществующие в прайсе товары,заказанные разными магазинами, каждый раз заносятся в новую книгу, это возможно,чтобы они добавлялись в одну книгу,а лучше, в другой лист книги с прайсом, в один список друг под другом и назвать его,например,"Нет в прайсе". Что касается повторов в прайсе,они мне не страшны,прайс у меня всегда отсортирован,заказы будут рядом,их всегда можно будет заметить. Еще раз Вам спасибо за помощь. Последний раз редактировалось Niki12; 05.03.2013 в 16:57.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Макрос для копирования значений из нескольких файлов в один общий с определенным условием копирования	zenner	Microsoft Office Excel	0	21.03.2011 14:48
Как собирать объявления с других сайтов в один общий?	ww888	Помощь студентам	1	23.07.2010 20:28
Один сервер и несколько клиентов: организация передачи файлов	evgenidem	Работа с сетью в Delphi	0	23.11.2009 11:26
Как перенести данные столбцов в один столбец?	CaustiC	Microsoft Office Excel	4	04.03.2009 11:11
Как вывести один столбец в несколько???	M&Ms	Microsoft Office Excel	9	21.07.2008 14:19

05.03.2013, 06:00	#11
Niki12 Регистрация: 13.05.2012 Сообщений: 9	Уважаемые Hugo121 и staniiislav! Огромное спасибо за отклик! Код,предложенный в посте №4,меня очень устроил! Работает! Ситуация,когда магазин заказывает товар не из прайса,действительно часто бывает,если бы макрос выводил список таких товаров,было бы просто супер! Но и без этого я Вам безмерно благодарна! Но если Вы имеете желание в коде что-то подправить,я думаю,вопрос "Произвести поиск" наверное не нужен,ведь и так понятно,что для этого-то макрос и запускают.Еще раз огромное-преогромное спасибо!!!!!