Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 04.03.2013, 13:39   #1
Niki12
 
Регистрация: 13.05.2012
Сообщений: 9
По умолчанию Как разнести заказы клиентов в один общий столбец

Уважаемые форумчане! Очень нужен макрос! Имеется прайс с большим наименованием товаров, до 8000, и заказ клиента,с указанием товаров и нужного количества этих товаров. Нужно,чтобы макрос в столбец с общим заказом добавил заказ клиента, а если в ячейке уже стоит заказ предыдущего клиента,нужно,чтобы он через запятую добавил заказ настоящего клиента. На самом деле клиентов очень много, я могла бы запускать такой макрос каждый раз после прихода очередного заказа,а сейчас я все это делаю вручную,очень тяжело. Пример в прилагаемом файле. Очень прошу помощи!
Вложения
Тип файла: zip Общий заказ.zip (2.0 Кб, 20 просмотров)
Niki12 вне форума Ответить с цитированием
Старый 04.03.2013, 14:18   #2
Скрипт
Форумчанин
 
Регистрация: 24.12.2012
Сообщений: 906
По умолчанию

Niki12, напишите на примере выложенной вами книги, что должен сделать макрос.

Например:
  1. пользователь нажимает на кнопку;
  2. макрос движется по столбцу "A";
  3. берёт данные из ячейки и что дальше?
Скрипт вне форума Ответить с цитированием
Старый 04.03.2013, 15:12   #3
staniiislav
Форумчанин
 
Аватар для staniiislav
 
Регистрация: 16.04.2010
Сообщений: 695
По умолчанию

пробуйте, если правильно понял:

Код:
Option Explicit

Sub Niki12()
Dim a(), b(), c(), i&, j&, n&
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)

Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row).ClearContents
With CreateObject("scripting.dictionary")
    For i = 1 To UBound(b)
        If Not .Exists(b(i, 1)) Then
            .Item(b(i, 1)) = 0& '.Item(b(i, 1))
        End If
    Next i
    For i = 1 To UBound(a)
        If .Exists(a(i, 1)) Then
            For j = 1 To UBound(b)
                If a(i, 1) = b(j, 1) Then
                    If Len(a(i, 2)) Then
                        c(i, 1) = a(i, 2) & ", " & b(j, 2)
                    Else
                        c(i, 1) = b(j, 2)
                    End If
                End If
            Next j
        End If
    Next i
End With
Range("H2").Resize(UBound(c)).Value = c
MsgBox "Поиск завершен.", vbInformation, "Поиск"
End Sub
Вложения
Тип файла: rar Общий заказ 2.rar (12.6 Кб, 19 просмотров)
Единственный способ стать умнее, играть с более умным противником...

Последний раз редактировалось staniiislav; 04.03.2013 в 15:41.
staniiislav вне форума Ответить с цитированием
Старый 04.03.2013, 17:37   #4
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Станислав, кажется перемудрили
Я немного Ваш код изменил.

Код:
Sub Niki12()
    Dim a(), b(), c(), il&, i&, t&
    If MsgBox("Произвести поиск?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    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 'что ищем, чем пополняем

    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)
            End If
        Next i
    End With
    'тут выгружаем назад в B2, но сейчас для теста в H2
    Range("H2").Resize(UBound(b)).Value = b
    MsgBox "Поиск завершён.", vbInformation, "Поиск"
End Sub
Но количество символов в ячейке ограничено - смотрите не превысьте!
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 04.03.2013, 17:47   #5
staniiislav
Форумчанин
 
Аватар для staniiislav
 
Регистрация: 16.04.2010
Сообщений: 695
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Станислав, кажется перемудрили
Я немного Ваш код изменил.

Код:
Sub Niki12()
    Dim a(), b(), c(), il&, i&, t&
    If MsgBox("Произвести поиск?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    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 'что ищем, чем пополняем

    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)
            End If
        Next i
    End With
    'тут выгружаем назад в B2, но сейчас для теста в H2
    Range("H2").Resize(UBound(b)).Value = b
    MsgBox "Поиск завершён.", vbInformation, "Поиск"
End Sub
Но количество символов в ячейке ограничено - смотрите не превысьте!
Блин, или я не понимаю суть вопросов или (скорое всего), нечего мне мне этими делами программными заниматься, видимо не заточены извилины у меня под программирование
Единственный способ стать умнее, играть с более умным противником...
staniiislav вне форума Ответить с цитированием
Старый 04.03.2013, 17:58   #6
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Да ну, не расстраивайтесь, Ваш вариант тоже почти работает (не сохраняет те данные, которым нет дополнения).
Просто нужно было в словарь заносить сперва тех, где будем искать, и сразу с их координатами.
Затем перебор тех, кого ищем, и по координатам дополняем строку.
Кстати, в моём коде упущен такой момент - если вдруг в заказе появился товар, которого нет в прайсе, то это просто молча будет игнорировано. Нужно бы хоть сообщение вывести... А лучше собрать в другой словарь с товаром в итем, затем выгрузить под список (и предусмотреть и тут повтор заказов).
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 04.03.2013, 18:31   #7
staniiislav
Форумчанин
 
Аватар для staniiislav
 
Регистрация: 16.04.2010
Сообщений: 695
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Да ну, не расстраивайтесь, Ваш вариант тоже почти работает (не сохраняет те данные, которым нет дополнения).
Просто нужно было в словарь заносить сперва тех, где будем искать, и сразу с их координатами.
Затем перебор тех, кого ищем, и по координатам дополняем строку.
Кстати, в моём коде упущен такой момент - если вдруг в заказе появился товар, которого нет в прайсе, то это просто молча будет игнорировано. Нужно бы хоть сообщение вывести... А лучше собрать в другой словарь с товаром в итем, затем выгрузить под список (и предусмотреть и тут повтор заказов).
я не расстраиваюсь, просто иногда бесит некоторые ситуации, которые изначально не предусмотрел
Единственный способ стать умнее, играть с более умным противником...
staniiislav вне форума Ответить с цитированием
Старый 04.03.2013, 18:52   #8
staniiislav
Форумчанин
 
Аватар для staniiislav
 
Регистрация: 16.04.2010
Сообщений: 695
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
Кстати, в моём коде упущен такой момент - если вдруг в заказе появился товар, которого нет в прайсе, то это просто молча будет игнорировано. Нужно бы хоть сообщение вывести... А лучше собрать в другой словарь с товаром в итем, затем выгрузить под список (и предусмотреть и тут повтор заказов).
все равно пока не могу понять как эти условия выполнить
Единственный способ стать умнее, играть с более умным противником...
staniiislav вне форума Ответить с цитированием
Старый 04.03.2013, 18:58   #9
staniiislav
Форумчанин
 
Аватар для staniiislav
 
Регистрация: 16.04.2010
Сообщений: 695
По умолчанию

завтра че нить придумаю
Единственный способ стать умнее, играть с более умным противником...
staniiislav вне форума Ответить с цитированием
Старый 04.03.2013, 19:05   #10
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Ну как - если критерий есть в словаре, то извлекаем координаты и дополняем строку. Если нет в словаре - заносим эти данные в словарь ненайденных, или в другой массив, или сразу пишем на лист. Но проверить на повтор (допустим магазин2 заказал товар150, затем ещё что-то, затем вдруг ещё товар150) проще используя словарь.
Возможно, на практике в данном случае такой случай исключён, но в теории ведь возможен? (сорри за нарочную тавтологию )
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Макрос для копирования значений из нескольких файлов в один общий с определенным условием копирования 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