Отправляет email-рассылки с помощью сервиса Sendsay

RFpro.ru: Программирование на Basic / VBA

Подписаться Бесплатная «Золотая» новостная рассылка . Подписчиков 1.823 RSS
←   Август 2009   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31


За последние 60 дней ни разу не выходила


Сайт рассылки: http://prog.rusfaq.ru/basic
Открыта: 14-03-2002

Автор
Калашников О.А.

Статистика

1.823 подписчиков
0 за неделю
←   Все выпуски   →

RFpro.ru: Программирование на Basic / VBA


Хостинг портала RFpro.ru:
Московский хостер
Профессиональный платный хостинг на базе Windows 2008

РАССЫЛКИ ПОРТАЛА RFPRO.RU

Чемпионы рейтинга экспертов в этой рассылке

Megaloman
Статус: Практикант
Рейтинг: 404
∙ повысить рейтинг » 		Тимошенко Дмитрий
Статус: Студент
Рейтинг: 390
∙ повысить рейтинг » 		Чичерин Вадим Викторович
Статус: 10-й класс
Рейтинг: 379
∙ повысить рейтинг »

/ КОМПЬЮТЕРЫ И ПО / Языки программирования / Basic/VBA

Номер выпуска:921
Дата выхода:22.08.2009, 14:35
Администратор рассылки:Калашников О.А., Руководитель
Подписчиков / экспертов:362 / 92
Вопросов / ответов:1 / 3

Вопрос № 171421: Здравствуйте, Уважаемые Эксперты! Помогите, пожалуйста, с решением задачи: Нужен макрос, для подсчета значений и удаление повторяющихся _Q________ __R дом__________1 дом__________1 дом__________1 соль__________1 соль__________...

Вопрос № 171421:

Здравствуйте, Уважаемые Эксперты!
Помогите, пожалуйста, с решением задачи:
Нужен макрос, для подсчета значений и удаление повторяющихся
_Q________ __R
дом__________1
дом__________1
дом__________1
соль__________1
соль__________1

_Q________ __R
дом__________3
соль__________2

именно столбцы Q_R
А если можно по подробнее , что, как, почему
С уважением

Отправлен: 17.08.2009, 14:07
Вопрос задал: Заргарян Марат Карленович, Посетитель
Всего ответов: 3
Страница вопроса »

Отвечает Тесленко Евгений Алексеевич, Практикант :
Здравствуйте, Заргарян Марат Карленович.
Если Ваша задача выполняется в MS Excel и данные имеют табличный вид, можно SQL запросом подключив библиотеку ADO.
Евгений. Прикрепленный файл: загрузить »

Ответ отправил: Тесленко Евгений Алексеевич, Практикант
Ответ отправлен: 18.08.2009, 01:23

Как сказать этому эксперту "спасибо"?
  • Отправить SMS #thank 253329 на номер 1151 (Россия) | Еще номера »
  • Отправить WebMoney:
    • Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    Отвечает Botsman, Специалист :
    Здравствуйте, Заргарян Марат Карленович.
    Судя по вашему вопросу, вы работаете с Excel (в принципе, есть и другое ПО, в котором есть столбцы Q и R, но рискну предположить :)
    В приложении - макрос решающий поставленную вами задачу с построчными комментариями "что, как и почему" - старался писать по возможности более подробно и понятно
    В отсутствии информации о версии Excel, я старался не использовать специфичных конструкций (макрос написан и оттестирован в Excel 2007), поэтому думаю, что все должно работать, но если что - пишите в минифорум.
    Все.
    Рад был помочь.

    Приложение:

    -----
    Хочешь победить Excel? Спроси меня как! ;)

    Ответ отправил: Botsman, Специалист
    Ответ отправлен: 18.08.2009, 10:25

    Как сказать этому эксперту "спасибо"?
  • Отправить SMS #thank 253336 на номер 1151 (Россия) | Еще номера »
  • Отправить WebMoney:
    • Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    Отвечает Megaloman, Практикант :
    Здравствуйте, Заргарян Марат Карленович.
    Предлагаю Вам несколько иное решение по сравнению с Botsman.
    Я сначала забираю фрагмент таблицы с данными в массив и уже его преобразую.
    В массиве оставляю только уникальные названия и подсчитываю для них количества.
    Очищаю фрагмент таблицы с исходными данными
    Записываю на его место упорядоченный фрагмент массива.

    Что я добиваюсь обработкой в массиве:
    1. Скорость выполнения
    2. Минимум движений на экране при преобразованиях.

    Описание работы макроса сделано по его тексту.
    Единственное, для работы надо указать адрес самой верхней клетки с наименованиями (у меня это "Q5").

    Код:
    Sub zzz()
    ' В указанном столбце начиная с указанной клетки имеются наименования
    '
  Среди наименований не может быть пустых клеток
    ' В соседнем столбце справа - их количество
    ' Вместо исходного фрагмента записываем изменённый, где:
    '       исключены повторяющиеся строки
    '       и подсчитано объединённое кол-во для каждого наименования

    ' Описание условия задачи
        FirstCell = "Q5"                ' Адрес первой клетки диапазона данных
    ' ---------------------------------
        
        iCol = Range(FirstCell).Column            
 ' Определим номер столбца с наименованиями
        iRow = Range(FirstCell).Row                 ' Определим номер начальной строки с наименованиями
        kRow = Range(FirstCell).End(xlDown).Row     ' Определим номер конечной строки с наименованиями
        
        Dim Mass As Variant
        
        Mass = Range(Cells(iRow, iCol), Cells(kRow, iCol + 1))  ' Забираем диапазон наименований и количеств в массив
           
        N1 = UBound(Mass, 1)              
   ' Определяем размерность массива (= числу строк и столбцов фрагмента таблицы)
        
        If N1 > 1 Then
            NN1 = N1
            i = 1
            Do While i < NN1
                M = 0
                j = i + 1
                Do While j + M <= NN1
                    If M <> 0 Then
                        Mass(j, 1) = Mass(j + M, 1)                      ' Перетаскиваю нижестоящие элементы на место одинаковых
                        Mass(j, 2) = Mass(j + M, 2)
                  
 End If
                    If Mass(i, 1) = Mass(j, 1) Then                       ' В массиве Для i элемента ищем элементы с бОльшим номером j (т е одинаковые наименования)
                       Mass(i, 2) = Mass(i, 2) + Mass(j, 2)               ' Если наименования =, то для i элемента добавляю количество от j элемента
                       M = M + 1
                    Else
                       j = j + 1
                    End If
                Loop
                
 NN1 = NN1 - M
                i = i + 1
            Loop
        End If
        
        Range(Cells(iRow, iCol), Cells(kRow, iCol + 1)).ClearContents               ' Чистим старые данные
        Range(Cells(iRow, iCol), Cells(kRow - (N1 - NN1), iCol + 1)) = Mass         ' Записываем новые данные
        
        Range(FirstCell).Select
        
    End Sub

    -----
    Нет времени на медленные танцы

    Ответ отправил: Megaloman, Практикант
    Ответ отправлен: 18.08.2009, 19:14

    Как сказать этому эксперту "спасибо"?
  • Отправить SMS #thank 253363 на номер 1151 (Россия) | Еще номера »
  • Отправить WebMoney:
    • Вам помогли? Пожалуйста, поблагодарите эксперта за это!

    Оценить выпуск »
    Нам очень важно Ваше мнение об этом выпуске рассылки!

    Задать вопрос экспертам этой рассылки »

    Скажите "спасибо" эксперту, который помог Вам!

    Отправьте СМС-сообщение с тестом #thank НОМЕР_ОТВЕТА
    на короткий номер 1151 (Россия)
    Номер ответа и конкретный текст СМС указан внизу каждого ответа.

    Полный список номеров »

    * Стоимость одного СМС-сообщения от 7.15 руб. и зависит от оператора сотовой связи. (полный список тарифов)
    ** При ошибочном вводе номера ответа или текста #thank услуга считается оказанной, денежные средства не возвращаются.
    *** Сумма выплаты эксперту-автору ответа расчитывается из суммы перечислений на портал от биллинговой компании.

    © 2001-2009, Портал RFpro.ru, Россия
    Авторское право: ООО "Мастер-Эксперт Про"
    Автор: Калашников О.А. | Программирование: Гладенюк А.Г.
    Хостинг: Компания "Московский хостер"
    Версия системы: 2009.6.7 от 15.08.2009
    В избранное