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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос ставящий рядом столбцы с одинаковыми заголовками - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос ставящий рядом столбцы с одинаковыми заголовками (Макросы/Sub)
Макрос ставящий рядом столбцы с одинаковыми заголовками
persona123 Дата: Вторник, 29.05.2018, 12:23 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый день.

Помогите решить одну проблему. Есть огромная табличка с множеством повторяющихся заголовков (см. файл пример). Нужно решение, чтобы в выделенной области все столбцы с одинаковыми заголовками вставали рядом друг с другом. Причем столбцы, заголовки которых не повторялись, вставали после повторяющихся.

Если реализовать такое не получится, то можно ограничиться вариантом, когда просто столбцы с одинаковыми заголовками были рядом друг с другом.
К сообщению приложен файл: 1122664.xls(28.5 Kb)
 
Ответить
СообщениеДобрый день.

Помогите решить одну проблему. Есть огромная табличка с множеством повторяющихся заголовков (см. файл пример). Нужно решение, чтобы в выделенной области все столбцы с одинаковыми заголовками вставали рядом друг с другом. Причем столбцы, заголовки которых не повторялись, вставали после повторяющихся.

Если реализовать такое не получится, то можно ограничиться вариантом, когда просто столбцы с одинаковыми заголовками были рядом друг с другом.

Автор - persona123
Дата добавления - 29.05.2018 в 12:23
sboy Дата: Вторник, 29.05.2018, 12:34 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2111
Репутация: 605 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
Вариант мышкой
-выделяем таблицу, копировать
-в свободное место специальная вставка - транспонировать
-сортируем полученную таблицу по 1 столбцу, копировать
-специальная вставка - транспонировать
 
Ответить
СообщениеДобрый день.
Вариант мышкой
-выделяем таблицу, копировать
-в свободное место специальная вставка - транспонировать
-сортируем полученную таблицу по 1 столбцу, копировать
-специальная вставка - транспонировать

Автор - sboy
Дата добавления - 29.05.2018 в 12:34
sboy Дата: Вторник, 29.05.2018, 12:51 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 2111
Репутация: 605 ±
Замечаний: 0% ±

Excel 2010
Тоже самое макросом
[vba]
Код
Sub Sort_Columns()
Application.ScreenUpdating = False
    Set dataR = Cells(1).CurrentRegion
    arr_ = dataR.Value
    Set lc = Cells.SpecialCells(xlCellTypeLastCell)
    Set tmpR = lc.Offset(1, 1).Resize(UBound(arr_, 2), UBound(arr_, 1))
    Set sortkey = lc.Offset(1, 1).Resize(UBound(arr_, 2), 1)
    tmpR.Value = Application.Transpose(arr_)
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=sortkey _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Лист1").Sort
            .SetRange tmpR
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    dataR.Value = Application.Transpose(tmpR.Value)
    tmpR.ClearContents
Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: persona.xls(39.5 Kb)


Сообщение отредактировал sboy - Вторник, 29.05.2018, 12:52
 
Ответить
СообщениеТоже самое макросом
[vba]
Код
Sub Sort_Columns()
Application.ScreenUpdating = False
    Set dataR = Cells(1).CurrentRegion
    arr_ = dataR.Value
    Set lc = Cells.SpecialCells(xlCellTypeLastCell)
    Set tmpR = lc.Offset(1, 1).Resize(UBound(arr_, 2), UBound(arr_, 1))
    Set sortkey = lc.Offset(1, 1).Resize(UBound(arr_, 2), 1)
    tmpR.Value = Application.Transpose(arr_)
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=sortkey _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Лист1").Sort
            .SetRange tmpR
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    dataR.Value = Application.Transpose(tmpR.Value)
    tmpR.ClearContents
Application.ScreenUpdating = True
End Sub
[/vba]

Автор - sboy
Дата добавления - 29.05.2018 в 12:51
persona123 Дата: Вторник, 29.05.2018, 12:52 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Благодарю. Проверил, работает. Спасибо.
 
Ответить
СообщениеБлагодарю. Проверил, работает. Спасибо.

Автор - persona123
Дата добавления - 29.05.2018 в 12:52
_Boroda_ Дата: Вторник, 29.05.2018, 16:01 | Сообщение № 5
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13194
Репутация: 5425 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
По убыванию количества столбцов

Последний кусок с расстановкой столбцов можно для ускорения переписать на автосотрировке, но сейчас некогда
К сообщению приложен файл: 112266_1.xlsm(19.2 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПо убыванию количества столбцов

Последний кусок с расстановкой столбцов можно для ускорения переписать на автосотрировке, но сейчас некогда

Автор - _Boroda_
Дата добавления - 29.05.2018 в 16:01
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос ставящий рядом столбцы с одинаковыми заголовками (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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