Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как перевернуть таблицу через разное количество строчек
 
#1
30.08.2022 11:16:34
Добрый день, есть такая проблема.
Есть рапорт с часами работников. Но его высылают не в том виде который нужен.
В рапорте все работники и часы идут просто в строчка вниз а нужен как в примере в файле. Работников очень много, и в ручную очень долго делать. Может у кого есть решение этой проблемы, буду очень благодарна
Нашла способ как это сделать, но только если все работники проработали одинаковое кол-во дней. Но проблема в том что некоторые работники вышли не 1 числа, а 4-5, иногда 20.
Подскажите формулу или может как добавить строчки быстро тем, кто вышел на работу не 1 числа
 
 
 
#2
30.08.2022 11:50:51
Здравствуйте. Можно сделать макросом. Только в файле-примере на одном листе покажите исходные данные, а на другом то что должно получиться. А то сотрудников 5 в столбце "А", а в столбце "Е" только один.  
Удивление есть начало познания © Surprise me!
И да пребудет с нами сила ВПР.
 
 
 
#3
30.08.2022 11:55:00
Добрый день вариант в PQ:
Вредить легко, помогать трудно.
 
 
 
#4
30.08.2022 12:01:52
вариант PQ
 
 
 
#5
30.08.2022 12:15:10
Код
Sub Karta_pracy()
    Dim rr As Range
    With ActiveSheet
        Set rr = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 2))
    End With
    
    Dim arr As Variant
    arr = rr
    
    Dim dicX As Object
    Set dicX = CreateObject("Scripting.Dictionary")
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    dicY.CompareMode = 1
    
    Dim yy As Long
    For yy = 1 To UBound(arr, 1)
        If IsDate(arr(yy, 1)) Then
            arr(yy, 1) = CDate(arr(yy, 1))
            dicX.Item(arr(yy, 1)) = 0
        Else
            'If Not dicY.Exists(arr(yy, 1)) Then
                dicY.Item(arr(yy, 1)) = dicY.Count
            'End If
        End If
    Next
    
    If dicX.Count = 0 Then Exit Sub
    If dicY.Count = 0 Then Exit Sub
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    Dim sh As Worksheet
    Set sh = wb.Sheets(1)
    
    Dim brr As Variant
    With sh.Cells(1, 1).Resize(dicX.Count, 1)
        .Value = Application.Transpose(dicX.Keys())
        .RemoveDuplicates Columns:=1, Header:=xlNo
        brr = .Value
        .Clear
    End With
    
    For yy = 1 To UBound(brr, 1)
        If dicX.Exists(CDate(brr(yy, 1))) Then
            dicX.Item(CDate(brr(yy, 1))) = yy
        End If
    Next
    
    sh.Columns(1).ColumnWidth = rr.Columns(1).ColumnWidth
    
    Dim xOut As Long
    Dim yOut As Long
    yOut = 2
    For yy = 1 To UBound(arr, 1)
        xOut = 1
        If dicY.Exists(arr(yy, 1)) Then
            yOut = dicY.Item(arr(yy, 1)) + 2
            rr.Cells(yy, 1).Copy sh.Cells(yOut, 1)
        Else
            If dicX.Exists(arr(yy, 1)) Then
                xOut = dicX.Item(arr(yy, 1)) + 1
            End If
            rr.Cells(yy, 1).Copy sh.Cells(1, xOut)
            rr.Cells(yy, 2).Copy sh.Cells(yOut, xOut)
        End If
    Next
    Cells(2, 2).Select
    ActiveWindow.FreezePanes = True
    
    Application.Calculation = Application_Calculation
    wb.Saved = True
End Sub
 
 
 
#6
30.08.2022 12:33:46
Цитата
написал:
вариант PQ
Спасибо. А как протянуть вниз это всё, когда  буду добавлять следующие строки?
 
 
 
#7
30.08.2022 13:35:29
что именно протянуть? добавляете новые данные в умную таблицу и жмете Обновить все
 
 
 
#8
30.08.2022 13:50:34
Добрый день, помогите с задачей. Необходимо данные из одной таблица переность в другую, расположенную на другом листе. При этом если значение столбца C больше 1000, то нужно этот столбец разделить на две строки. Можно ли это как то реализовать?  
 
 
 
#9
30.08.2022 15:06:46
Название темы - бомба  :D
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#10
30.08.2022 16:06:40
Цитата
написал:
Название темы - бомба  
Спасибо)
 
 
 
#11
30.08.2022 16:23:38
Цитата
написал:
что именно протянуть? добавляете новые данные в умную таблицу и жмете Обнов
Добавила дальше часы, но ничего не обновилось
Прикрепила файл
 
 
 
#12
31.08.2022 12:07:42
Цитата
Добавила дальше часы, но ничего не обновилось
Добавьте на лист в ячейку D1 номер месяца (8), а в D2 год (2022)
присланного отчета и запустите макрос Sub RotationTable()
Код
Option Explicit

Sub RotationTable()
Dim i As Integer
Dim n As Integer
Dim iLastRow As Long
Dim iLR As Long
Dim BeginRow As Long
Dim EndRow As Long
Dim iFIO As String
Dim iDateBegin As Date
Dim FoundDate As Range
    With Application
      .ScreenUpdating = False                    'отключение обновление экрана
      .Calculation = xlCalculationManual         'отключение пересчёт формул вручную
      .DisplayAlerts = False                     'отключение предупреждающих сообщений
    End With
Dim iLastDay As Integer     'последний день месяца и года из ячеек D1 и D2
Dim iDate As Date
  Range("F1:AJ1").ClearContents
   iLastDay = Day(DateSerial(Range("D2"), Range("D1") + 1, 1) - 1)
     For i = 1 To iLastDay      'заполняем первую строку от столбца F датами
       Cells(1, 5 + i) = DateSerial(Range("D2"), Range("D1"), i)
     Next
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("E2:AJ" & iLastRow).Clear
     BeginRow = 2   'строка с ФИО
   For i = BeginRow To iLastRow
        n = 0
      Do                    'ищем диапазон с данными по каждой ФИО
        n = n + 1
        EndRow = BeginRow + n
      Loop While IsDate(Cells(EndRow, "A"))
      
      iDateBegin = Format(Cells(BeginRow + 1, "A"), "dd.mm.yyyy")
        Set FoundDate = Rows(1).Find(iDateBegin, , xlFormulas, xlWhole)
        iLR = Cells(Rows.Count, "E").End(xlUp).Row + 1  'следующая строка в столбце Е
      Cells(iLR, "E") = Cells(BeginRow, "A")            'ФИО
      Range(Cells(BeginRow + 1, "B"), Cells(EndRow - 1, "B")).Copy
      Cells(iLR, FoundDate.Column).PasteSpecial xlPasteAll, Transpose:=True
      Range(Cells(iLR, FoundDate.Column), Cells(iLR, 5 + iLastDay)).HorizontalAlignment = xlCenter
      BeginRow = EndRow
      i = i + n - 1
   Next
       Range("A2").Activate
    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With
End Sub
Изменено: Kuzmich - 31.08.2022 12:09:45
 
 
 
#13
31.08.2022 12:35:27
Anzhela Gerasymenko, где не обновилось? на листе 2?
 
 
 
Страницы: 1
Наверх