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

Вход

Регистрация

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

 

= Мир MS Excel/Перенести ячейки из строчного вида в столбик друг под другом - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Перенести ячейки из строчного вида в столбик друг под другом
leonteva1199 Дата: Четверг, 15.02.2024, 13:36 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

2019
Помогите, как перенести ячейки из строки в столбец? С макросами не дружу((
К сообщению приложен файл: 3434843.xlsx (18.5 Kb)


Сообщение отредактировал leonteva1199 - Четверг, 15.02.2024, 13:43
 
Ответить
СообщениеПомогите, как перенести ячейки из строки в столбец? С макросами не дружу((

Автор - leonteva1199
Дата добавления - 15.02.2024 в 13:36
Nic70y Дата: Четверг, 15.02.2024, 16:24 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 8972
Репутация: 2356 ±
Замечаний: 0% ±

Excel 2010
макрос в модуле книги
запускается двойным щелчком левой кнопки мыши по любой ячейке
[vba]
Код
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Cancel = True 'отмена* даблклика
    a = ActiveSheet.Name 'имя активного листа
    b = Cells(Rows.Count, "a").End(xlUp).Row 'нижнаяя строка таблицы (столбец A)
    If b > 3 Then '1-я фио должна быть в 4 строке, только тогда преобразуем
        d = 3       '1-й столбец января
        e = 9       'кол-во столбцом в месяце
        k = 3       'кол-во строк в шапке*
        'создадим лист результата
        Sheets.Add After:=Sheets(Sheets.Count)
        f = Sheets(Sheets.Count).Name 'имя листа результата
        'пройдемся циклом по фио
        For g = k + 1 To b 'g - строка с очередной фамилией
            'фио-остаток
            m = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row + 1
            Sheets(a).Range("a1:b3").Copy Sheets(f).Range("a" & m)
            Sheets(a).Range("a" & g & ":b" & g).Copy Sheets(f).Range("a" & m + k)
            'пройдемся циклом по месяцам
            For h = 1 To 12
                i = (h - 1) * e + d 'левый столбец месяца
                j = h * e + d - 1   'правый столбец месяца
                l = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row + 1 'строка вставки
                'копируем-втавляем шапку
                Sheets(a).Range(Sheets(a).Cells(1, i), Sheets(a).Cells(k, j)).Copy Sheets(f).Range("c" & l)
                'копируем-втавляем данные
                Sheets(a).Range(Sheets(a).Cells(g, i), Sheets(a).Cells(g, j)).Copy Sheets(f).Range("c" & l + k)
            Next
            'объединим и установим границы
            n = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row
            With Sheets(f).Range("a" & m + k & ":a" & n)
                .Merge
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
            Sheets(f).Range("b" & n).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Next
    End If
    Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: 215.xlsm (30.1 Kb)


ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Четверг, 15.02.2024, 16:35
 
Ответить
Сообщениемакрос в модуле книги
запускается двойным щелчком левой кнопки мыши по любой ячейке
[vba]
Код
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    Cancel = True 'отмена* даблклика
    a = ActiveSheet.Name 'имя активного листа
    b = Cells(Rows.Count, "a").End(xlUp).Row 'нижнаяя строка таблицы (столбец A)
    If b > 3 Then '1-я фио должна быть в 4 строке, только тогда преобразуем
        d = 3       '1-й столбец января
        e = 9       'кол-во столбцом в месяце
        k = 3       'кол-во строк в шапке*
        'создадим лист результата
        Sheets.Add After:=Sheets(Sheets.Count)
        f = Sheets(Sheets.Count).Name 'имя листа результата
        'пройдемся циклом по фио
        For g = k + 1 To b 'g - строка с очередной фамилией
            'фио-остаток
            m = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row + 1
            Sheets(a).Range("a1:b3").Copy Sheets(f).Range("a" & m)
            Sheets(a).Range("a" & g & ":b" & g).Copy Sheets(f).Range("a" & m + k)
            'пройдемся циклом по месяцам
            For h = 1 To 12
                i = (h - 1) * e + d 'левый столбец месяца
                j = h * e + d - 1   'правый столбец месяца
                l = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row + 1 'строка вставки
                'копируем-втавляем шапку
                Sheets(a).Range(Sheets(a).Cells(1, i), Sheets(a).Cells(k, j)).Copy Sheets(f).Range("c" & l)
                'копируем-втавляем данные
                Sheets(a).Range(Sheets(a).Cells(g, i), Sheets(a).Cells(g, j)).Copy Sheets(f).Range("c" & l + k)
            Next
            'объединим и установим границы
            n = Sheets(f).Cells(Rows.Count, "c").End(xlUp).Row
            With Sheets(f).Range("a" & m + k & ":a" & n)
                .Merge
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
            Sheets(f).Range("b" & n).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Next
    End If
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 15.02.2024 в 16:24
leonteva1199 Дата: Пятница, 16.02.2024, 09:13 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

2019
Nic70y, спасибо огромное! Вы гений)) Спасли меня от много часов копировать-вставить
 
Ответить
СообщениеNic70y, спасибо огромное! Вы гений)) Спасли меня от много часов копировать-вставить

Автор - leonteva1199
Дата добавления - 16.02.2024 в 09:13
  • Страница 1 из 1
  • 1
Поиск:

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