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

Вход

Регистрация

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

 

= Мир MS Excel/Транспонирование КонтрАгентов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Транспонирование КонтрАгентов (Макросы/Sub)
Транспонирование КонтрАгентов
vova-vba Дата: Воскресенье, 19.02.2017, 02:29 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
Имеется таблица доходы по контрагентам по кварталам, требуется транспонировать в одну строку по месяцам, т.е таблицу вот такого вида :

Наименование организации 1мес 2мес 3мес Квартал
Первый 1 1 1 2
Первый 1 1 1 3
Первый 1 1 1 4
КонтрАгент1 1111 1111 1111 1
Фирма12 2 22 2 1
Фирма12 222 2 2 2
2агент 4545 67 67 1
2агент 4545 67 67 2
2агент 4545 67 454 3
2агент 4545 67 454 4
КонтрАгент3 333 333 333 3
Фирма 656 454 67 1
Фирма 5656 345 67 2
Фирма 854 65 67 3
Магазин 55 55 11 3
Магазин 55 55 67 4
СуперМаркет 34 7676 67 1
СуперМаркет 34 7676 67 2
СуперМаркет 34 7676 67 3
СуперМаркет 34 7676 454 4
КонтрАгент4 444 444 444 4
Ларек 234 234 454 1
Ларек 234 234 11 2
Ларек 234 234 67 3
СтройМатериалы 545 455 67 1
СтройМатериалы 545 455 67 2
СтройМатериалы 545 455 67 3
СтройМатериалы 545 455 454 4
КонтрАгент2 222 222 222 2
Аптека 656 45 67 2
Аптека 656 45 454 3
Аптека 656 45 454 4
Магазин123 55 55 11 2
Магазин123 55 55 67 3

получить таблицу вот такого вида :

Наименование организации 1мес 2мес 3мес Квартал 1 2 3 4 5 6 7 8 9 10 11 12
Первый 1 1 1 2 1 1 1 1 1 1 1 1 1
Первый 1 1 1 3
Первый 1 1 1 4
КонтрАгент1 1111 1111 1111 1 1111 1111 1111
Фирма12 2 22 2 1 2 22 2 222 2 2
Фирма12 222 2 2 2
2агент 4545 67 67 1 4545 67 67 4545 67 67 4545 67 454 4545 67 454
2агент 4545 67 67 2
2агент 4545 67 454 3
2агент 4545 67 454 4
КонтрАгент3 333 333 333 3 333 333 333
Фирма 656 454 67 1 656 454 67 5656 345 67 854 65 67
Фирма 5656 345 67 2
Фирма 854 65 67 3
Магазин 55 55 11 3 55 55 11 55 55 67
Магазин 55 55 67 4
СуперМаркет 34 7676 67 1 34 7676 67 34 7676 67 34 7676 67 34 7676 454
СуперМаркет 34 7676 67 2
СуперМаркет 34 7676 67 3
СуперМаркет 34 7676 454 4
КонтрАгент4 444 444 444 4 444 444 444
Ларек 234 234 454 1 234 234 454 234 234 11 234 234 67
Ларек 234 234 11 2
Ларек 234 234 67 3
СтройМатериалы 545 455 67 1 545 455 67 545 455 67 545 455 67 545 455 454
СтройМатериалы 545 455 67 2
СтройМатериалы 545 455 67 3
СтройМатериалы 545 455 454 4
КонтрАгент2 222 222 222 2 222 222 222
Аптека 656 45 67 2 656 45 67 656 45 454 656 45 454
Аптека 656 45 454 3
Аптека 656 45 454 4
Магазин123 55 55 11 2 55 55 11 55 55 67
Магазин123 55 55 67 3

сам файл прилагаю
К сообщению приложен файл: __.rar (54.4 Kb)


Сообщение отредактировал vova-vba - Воскресенье, 19.02.2017, 02:29
 
Ответить
СообщениеИмеется таблица доходы по контрагентам по кварталам, требуется транспонировать в одну строку по месяцам, т.е таблицу вот такого вида :

Наименование организации 1мес 2мес 3мес Квартал
Первый 1 1 1 2
Первый 1 1 1 3
Первый 1 1 1 4
КонтрАгент1 1111 1111 1111 1
Фирма12 2 22 2 1
Фирма12 222 2 2 2
2агент 4545 67 67 1
2агент 4545 67 67 2
2агент 4545 67 454 3
2агент 4545 67 454 4
КонтрАгент3 333 333 333 3
Фирма 656 454 67 1
Фирма 5656 345 67 2
Фирма 854 65 67 3
Магазин 55 55 11 3
Магазин 55 55 67 4
СуперМаркет 34 7676 67 1
СуперМаркет 34 7676 67 2
СуперМаркет 34 7676 67 3
СуперМаркет 34 7676 454 4
КонтрАгент4 444 444 444 4
Ларек 234 234 454 1
Ларек 234 234 11 2
Ларек 234 234 67 3
СтройМатериалы 545 455 67 1
СтройМатериалы 545 455 67 2
СтройМатериалы 545 455 67 3
СтройМатериалы 545 455 454 4
КонтрАгент2 222 222 222 2
Аптека 656 45 67 2
Аптека 656 45 454 3
Аптека 656 45 454 4
Магазин123 55 55 11 2
Магазин123 55 55 67 3

получить таблицу вот такого вида :

Наименование организации 1мес 2мес 3мес Квартал 1 2 3 4 5 6 7 8 9 10 11 12
Первый 1 1 1 2 1 1 1 1 1 1 1 1 1
Первый 1 1 1 3
Первый 1 1 1 4
КонтрАгент1 1111 1111 1111 1 1111 1111 1111
Фирма12 2 22 2 1 2 22 2 222 2 2
Фирма12 222 2 2 2
2агент 4545 67 67 1 4545 67 67 4545 67 67 4545 67 454 4545 67 454
2агент 4545 67 67 2
2агент 4545 67 454 3
2агент 4545 67 454 4
КонтрАгент3 333 333 333 3 333 333 333
Фирма 656 454 67 1 656 454 67 5656 345 67 854 65 67
Фирма 5656 345 67 2
Фирма 854 65 67 3
Магазин 55 55 11 3 55 55 11 55 55 67
Магазин 55 55 67 4
СуперМаркет 34 7676 67 1 34 7676 67 34 7676 67 34 7676 67 34 7676 454
СуперМаркет 34 7676 67 2
СуперМаркет 34 7676 67 3
СуперМаркет 34 7676 454 4
КонтрАгент4 444 444 444 4 444 444 444
Ларек 234 234 454 1 234 234 454 234 234 11 234 234 67
Ларек 234 234 11 2
Ларек 234 234 67 3
СтройМатериалы 545 455 67 1 545 455 67 545 455 67 545 455 67 545 455 454
СтройМатериалы 545 455 67 2
СтройМатериалы 545 455 67 3
СтройМатериалы 545 455 454 4
КонтрАгент2 222 222 222 2 222 222 222
Аптека 656 45 67 2 656 45 67 656 45 454 656 45 454
Аптека 656 45 454 3
Аптека 656 45 454 4
Магазин123 55 55 11 2 55 55 11 55 55 67
Магазин123 55 55 67 3

сам файл прилагаю

Автор - vova-vba
Дата добавления - 19.02.2017 в 02:29
vova-vba Дата: Воскресенье, 19.02.2017, 02:35 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
Так то сам код готов , работает нормально ,
вопрос в следующем , можно ли более оптимально и красивей или возможно существуют какие то стандартные методы
 
Ответить
СообщениеТак то сам код готов , работает нормально ,
вопрос в следующем , можно ли более оптимально и красивей или возможно существуют какие то стандартные методы

Автор - vova-vba
Дата добавления - 19.02.2017 в 02:35
gling Дата: Воскресенье, 19.02.2017, 09:30 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2519
Репутация: 674 ±
Замечаний: 0% ±

2010
Красиво или нет не знаю, но короче это точно.
[vba]
Код
Sub Кнопка2()
  Dim i As Long, j As Long, jj As Long, lLastRow As Long
    Application.ScreenUpdating = False
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("F2:Q" & lLastRow).Clear
        For j = 2 To lLastRow
        jj = Application.Match(Cells(j, 1), Range("A1:A" & lLastRow), 0)
          For i = 1 To 3
            Range(Cells(j, 2), Cells(j, 4)).Copy Cells(jj, 3 + 3 * Cells(j, 5))
          Next
        Next
    Range("F2:Q" & lLastRow).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub
[/vba]
Кросс
К сообщению приложен файл: vova-vba.xlsm (58.7 Kb)


ЯД-41001506838083

Сообщение отредактировал gling - Воскресенье, 19.02.2017, 09:44
 
Ответить
СообщениеКрасиво или нет не знаю, но короче это точно.
[vba]
Код
Sub Кнопка2()
  Dim i As Long, j As Long, jj As Long, lLastRow As Long
    Application.ScreenUpdating = False
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("F2:Q" & lLastRow).Clear
        For j = 2 To lLastRow
        jj = Application.Match(Cells(j, 1), Range("A1:A" & lLastRow), 0)
          For i = 1 To 3
            Range(Cells(j, 2), Cells(j, 4)).Copy Cells(jj, 3 + 3 * Cells(j, 5))
          Next
        Next
    Range("F2:Q" & lLastRow).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub
[/vba]
Кросс

Автор - gling
Дата добавления - 19.02.2017 в 09:30
vova-vba Дата: Воскресенье, 19.02.2017, 11:17 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
gling, вообще красота, я даже как после нокаута не могу понять от куда прилетело , сейчас сижу разбираю по буквам,
вообщем высший пилотаж,
я сейчас это дело зашаблоню сделаю что то типа загатовки шаблона

большое спасибо
 
Ответить
Сообщениеgling, вообще красота, я даже как после нокаута не могу понять от куда прилетело , сейчас сижу разбираю по буквам,
вообщем высший пилотаж,
я сейчас это дело зашаблоню сделаю что то типа загатовки шаблона

большое спасибо

Автор - vova-vba
Дата добавления - 19.02.2017 в 11:17
gling Дата: Воскресенье, 19.02.2017, 11:37 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2519
Репутация: 674 ±
Замечаний: 0% ±

2010
Для чего создавал переменную i, не знаю, можно без неё. В коде уберите i As Long, For i = 1 To 3 и Next Получится так[vba]
Код
Sub Кнопка2()
  Dim j As Long, jj As Long, lLastRow As Long
    Application.ScreenUpdating = False
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("F2:Q" & lLastRow).Clear
        For j = 2 To lLastRow
        jj = Application.Match(Cells(j, 1), Range("A1:A" & lLastRow), 0)
            Range(Cells(j, 2), Cells(j, 4)).Copy Cells(jj, 3 + 3 * Cells(j, 5))
        Next
    Range("F2:Q" & lLastRow).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub

[/vba]


ЯД-41001506838083

Сообщение отредактировал gling - Воскресенье, 19.02.2017, 11:40
 
Ответить
СообщениеДля чего создавал переменную i, не знаю, можно без неё. В коде уберите i As Long, For i = 1 To 3 и Next Получится так[vba]
Код
Sub Кнопка2()
  Dim j As Long, jj As Long, lLastRow As Long
    Application.ScreenUpdating = False
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("F2:Q" & lLastRow).Clear
        For j = 2 To lLastRow
        jj = Application.Match(Cells(j, 1), Range("A1:A" & lLastRow), 0)
            Range(Cells(j, 2), Cells(j, 4)).Copy Cells(jj, 3 + 3 * Cells(j, 5))
        Next
    Range("F2:Q" & lLastRow).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub

[/vba]

Автор - gling
Дата добавления - 19.02.2017 в 11:37
KuklP Дата: Воскресенье, 19.02.2017, 11:47 | Сообщение № 6
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Модеры, зайдите на Планету, плиз. Почитайте тему:
http://www.planetaexcel.ru/forum....rovanie


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеМодеры, зайдите на Планету, плиз. Почитайте тему:
http://www.planetaexcel.ru/forum....rovanie

Автор - KuklP
Дата добавления - 19.02.2017 в 11:47
vova-vba Дата: Воскресенье, 19.02.2017, 11:57 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
Для чего создавал переменную i, не знаю, можно без неё. В коде уберите i As Long, For i = 1 To 3 и Next Получится так


ОК , спасибо
 
Ответить
Сообщение
Для чего создавал переменную i, не знаю, можно без неё. В коде уберите i As Long, For i = 1 To 3 и Next Получится так


ОК , спасибо

Автор - vova-vba
Дата добавления - 19.02.2017 в 11:57
vova-vba Дата: Воскресенье, 19.02.2017, 12:06 | Сообщение № 8
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
gling к стате быстрей работает
 
Ответить
Сообщениеgling к стате быстрей работает

Автор - vova-vba
Дата добавления - 19.02.2017 в 12:06
vova-vba Дата: Воскресенье, 19.02.2017, 12:11 | Сообщение № 9
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: -1 ±
Замечаний: 0% ±

Excel 2010
а дальше больше , у меня вот так работает
[vba]
Код

Sub Êíîïêà2()
  
       For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        jj = Application.Match(Cells(j, 1), Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), 0)
            Range(Cells(j, 2), Cells(j, 4)).Copy Cells(jj, 3 + 3 * Cells(j, 5))
        Next
     
End Sub
[/vba]
 
Ответить
Сообщениеа дальше больше , у меня вот так работает
[vba]
Код

Sub Êíîïêà2()
  
       For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        jj = Application.Match(Cells(j, 1), Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), 0)
            Range(Cells(j, 2), Cells(j, 4)).Copy Cells(jj, 3 + 3 * Cells(j, 5))
        Next
     
End Sub
[/vba]

Автор - vova-vba
Дата добавления - 19.02.2017 в 12:11
gling Дата: Воскресенье, 19.02.2017, 12:19 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2519
Репутация: 674 ±
Замечаний: 0% ±

2010
Из-за Ваших оскорблений, на дружественном форуме, у меня нет желания с вами общаться, и объяснять почему прописаны дополнительные строки, и какие ошибки выскочат при вашем написании кода. Доходите до всего самостоятельно. Удачи.


ЯД-41001506838083
 
Ответить
СообщениеИз-за Ваших оскорблений, на дружественном форуме, у меня нет желания с вами общаться, и объяснять почему прописаны дополнительные строки, и какие ошибки выскочат при вашем написании кода. Доходите до всего самостоятельно. Удачи.

Автор - gling
Дата добавления - 19.02.2017 в 12:19
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Транспонирование КонтрАгентов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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