Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Разделение двух столбцов по фамилиям и транспонирование столбцов
 
#1
07.01.2021 18:21:52
есть файл с такой структурой. необходимо транспонировать его как в образце ( сделано специальной вставкой). но записей может быть две-три тысячи.
два столбца: в одном фамилия, затем идут названия месяцевБ причем количество месяцев может быть разным. другой столбец значения.

если возможно подскажите как с это сделать.
заранее спасибо.
 
 
 
#2
07.01.2021 19:56:30
Макросом.
Код
Sub Button1_Click()
    arrm = Array("январь", "февраль", "март", "апрель", "май", "июнь", "июль", "август", "сентябрь", "октябрь", "ноябрь", "декабрь")
    arri = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    Columns("E:R").ClearContents
    cr = 1
    cc = 5
    Set slov = CreateObject("scripting.dictionary")
    For i = 0 To UBound(arrm)
        slov(arrm(i)) = i
        Cells(1, cc + i + 2) = arrm(i)
    Next
    Cells(1, cc) = "ФИО"
    Cells(1, cc + 1) = "Итого"
    For i = 1 To UBound(arri)
        If Not slov.exists(arri(i, 1)) Then
            cr = cr + 1
            Cells(cr, cc) = arri(i, 1)
            Cells(cr, cc + 1) = arri(i, 2)
        Else
            Cells(cr, cc + slov(arri(i, 1)) + 2) = arri(i, 2)
        End If
    Next
End Sub
Изменено: skais675 - 07.01.2021 20:23:15
Мой канал
 
 
 
#3
07.01.2021 19:59:21
Формула для 12 месяцев.
Код
=INDEX($D$1:$P$230;13*CEILING(ROWS($1:1)/13;1)-13+COLUMNS($A:A);MOD(ROWS($1:1)-1;13)+1)
Изменено: jakim - 07.01.2021 20:03:07
 
 
 
#4
07.01.2021 20:15:16
skais675. большое спасибо. работает. название месяцев попробую сам дописать.
 
 
 
#5
07.01.2021 20:20:27
eif, поправил.
Мой канал
 
 
 
#6
07.01.2021 20:36:33
ещё большее спасибо
 
 
 
#7
07.01.2021 21:19:39
И еще вариант:
Код
Sub qwert()
Dim arrMonth(), ws As Worksheet, lRow%
arrMonth = Array("январь", "февраль", "март", "апрель", "май", _
"июнь", "июль", "август", "сентябрь", "октябрь", "ноябрь", "декабрь")
Set ws = ThisWorkbook.ActiveSheet
With ws
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    For x = 1 To lRow
        If Not IsNumeric(Application.Match(.Range("A" & x).Value, arrMonth, 0)) Then
            If x > 1 Then
                .Range("A" & rw, .Range("B" & x)).Copy
                .Range("D" & rw).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, True
            End If
            rw = x
            col = 4
        End If
        If x = lRow Then
            .Range("A" & rw, .Range("B" & x)).Copy
            .Range("D" & rw).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, True
        End If
    Next x
End With
End Sub
 
 
 
Страницы: 1
Наверх