Страницы: 1
RSS
Формирование служебной записки из графика выхода
 
Добрый день! Создан график выхода на работу, есть 4 вкладки:1. Годовой график
2. Тот же годовой, но в него вношу необходимые изменения
3. Тут уже пустая таблица, годовая и при изменения подсвечиваются именно изменённые дни
4. Уже непосредственно СЗ, но не пойму как сделать её автоматически заполняемой на основе таблицы №3?

Требуется чтоб в СЗ заносились фамилии по работникам у которых есть изменения в графике и так же числа дней изменений.
 
Вариант макросом.
Код
Option Explicit

Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub

Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub

Function GetArr() As Variant
    With Sheets("СВОДКА РЭС-7")
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim brr As Variant
    ReDim brr(0 To 0)
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
        
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                e = x
                Do
                    Select Case arr(y, e)
                    Case " "
                        e = e + 1
                    Case Else
                        e = e - 1
                        Exit Do
                    End Select
                Loop
                
                ReDim Preserve brr(0 To UBound(brr) + 1)
                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                x = e
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    If UBound(brr) = 0 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr), 1 To 7)
        For y = 1 To UBound(brr)
            orr(y, 1) = y
            orr(y, 2) = brr(y)(0)
            orr(y, 3) = brr(y)(1)
            orr(y, 4) = Empty
            orr(y, 5) = Empty
            orr(y, 6) = Empty
            orr(y, 7) = brr(y)(2) & " - " & brr(y)(3)
        Next
    End If
    GetArr = orr
End Function
Вариант названия темы
Формирование служебной записки из графика выхода
 
По названию да точно, просто в экселе слаб, не смог более точно сформулировать.
За макрос огромное спасибо, работает. Но только пока изменения в одном месяце, а график идет годовой, как только внес изменения во втором месяце выдало ошибку
Код
.Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove

Также когда изменения в один день макрос выводит "1 сентября-1 сентября", а если же изменений много и они разрывами идут, то создаются дублирующие строки, то есть даты не в одну ячейку вставляются, а заново строка, если будет 10 дней у человека с разрывом то и создастся 10 строк.
Изменено: vikttur - 13.09.2021 22:32:51
 
В таком варианте выводит по одному сотруднику одну строку с минимальной и максимальной датой.
Данный код работает на имеющемся примере.
Код
Option Explicit
'Версия 2.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub

Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub

Function GetArr() As Variant
    With Sheets("СВОДКА РЭС-7")
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
        
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                e = x
                Do
                    Select Case arr(y, e)
                    Case " "
                        e = e + 1
                    Case Else
                        e = e - 1
                        Exit Do
                    End Select
                Loop
                
                If Not dic.Exists(arr(y, 2)) Then
                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                Else
                    crr = dic.Item(arr(y, 2))
                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                End If
                dic.Item(arr(y, 2)) = crr
                
'                ReDim Preserve brr(0 To UBound(brr) + 1)
'                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                x = e
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If UBound(brr) < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        For y = 0 To UBound(brr)
            orr(y + 1, 1) = y
            orr(y + 1, 2) = brr(y)(0)
            orr(y + 1, 3) = brr(y)(1)
            orr(y + 1, 4) = Empty
            orr(y + 1, 5) = Empty
            orr(y + 1, 6) = Empty
            orr(y + 1, 7) = brr(y)(2) & " - " & brr(y)(3)
        Next
    End If
    GetArr = orr
End Function
 
Ну вот добрый человек спасибо бесконечное уже за внимание к моему вопросу. Конечно все работает, но вот нужно то именно даты изменений, а не мин и макс, то есть можно в одну ячейку сделать, через запятую допустим изменения, первая дата, потом вторая или период если он не раздельный. И еще если только один день изменения, можно избавиться от указания периода?
 
Код
Option Explicit
'Версия 3.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub

Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Dim rRow As Range
        For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
            rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
        Next
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub

Function GetArr() As Variant
    With Sheets("СВОДКА РЭС-7")
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
        
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                e = x
                Do
                    Select Case arr(y, e)
                    Case " "
                        e = e + 1
                    Case Else
                        e = e - 1
                        Exit Do
                    End Select
                Loop
                
                If Not dic.Exists(arr(y, 2)) Then
'                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                Else
'                    crr = dic.Item(arr(y, 2))
'                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                End If
                crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
                
'                ReDim Preserve brr(0 To UBound(brr) + 1)
'                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                x = e
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If UBound(brr) < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        Dim u As Long
        Dim v As Variant
        Dim dit As Object
        For y = 0 To UBound(brr)
            u = u + 1
            orr(u, 1) = y + 1
            orr(u, 2) = brr(y).Items()(0)(0)
            orr(u, 3) = brr(y).Items()(0)(1)
            Set dit = CreateObject("Scripting.Dictionary")
            For Each v In brr(y).Items()
    '            orr(y + 1, 3) = brr(y)(1)
    '            orr(y + 1, 4) = Empty
    '            orr(y + 1, 5) = Empty
    '            orr(y + 1, 6) = Empty
                dit.Item(Replace(v(2) & IIf(v(2) = v(3), "", " - " & v(3)), vbCrLf, "")) = 0
            Next
            orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
        Next
    End If
    GetArr = orr
End Function
 
МатросНаЗебре, отлично все работает, а можно в макросе самому выставлять или как еще сделать чтоб он проверял только нужный месяц. Допустим сентябрь СЗ уже подписана, нужно сделать на октябрь только а не по всему году? И по месяцам сделать вывод не в формате дата месяц, а 21.09.21 допустим. Признателен уже за вашу огромную помощь!
Изменено: vikttur - 21.09.2021 00:04:09
 
Выделите диапазон на листе СВОДКА РЭС-7. Запустите макрос.
Код
Option Explicit
'Версия 4.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub
 
Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Dim rRow As Range
        For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
            rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
        Next
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub
 
Function GetArr() As Variant
    Dim sh As Worksheet
    Set sh = Sheets("СВОДКА РЭС-7")
    With sh
        .Select 'Проверка выполняется по выделенным ячейкам
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
         
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                If Not Intersect(sh.Cells(y, x), Selection) Is Nothing Then
                    e = x
                    Do
                        Select Case arr(y, e)
                        Case " "
                            e = e + 1
                        Case Else
                            e = e - 1
                            Exit Do
                        End Select
                    Loop
                     
                    If Not dic.Exists(arr(y, 2)) Then
    '                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                        Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    Else
    '                    crr = dic.Item(arr(y, 2))
    '                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                    End If
                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
                     
    '                ReDim Preserve brr(0 To UBound(brr) + 1)
    '                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    x = e
                End If
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If dic.Count < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        Dim u As Long
        Dim v As Variant
        Dim dit As Object
        For y = 0 To UBound(brr)
            u = u + 1
            orr(u, 1) = y + 1
            orr(u, 2) = brr(y).Items()(0)(0)
            orr(u, 3) = brr(y).Items()(0)(1)
            Set dit = CreateObject("Scripting.Dictionary")
            For Each v In brr(y).Items()
    '            orr(y + 1, 3) = brr(y)(1)
    '            orr(y + 1, 4) = Empty
    '            orr(y + 1, 5) = Empty
    '            orr(y + 1, 6) = Empty
                dit.Item(Replace(v(2) & IIf(v(2) = v(3), "", " - " & v(3)), vbCrLf, "")) = 0
            Next
            orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
        Next
    End If
    GetArr = orr
End Function
 
Цитата
МатросНаЗебре написал:
Все круто работает, спасибо за помощь, без вас точно бы не сделал! А месяц (21 сентябрь) на формат даты в виде 21.09.21 реально сделать?
 
Mizorg, кнопка Имя как раз для того, чтобы обратиться по имени. А Вы вставляете непонятно что.
 
Код
Option Explicit
'Версия 5.
Sub Main()
    Dim arr As Variant
    arr = GetArr()
    OutArr arr
End Sub
 
Sub OutArr(arr As Variant)
    With Sheets("СЗ ")
        .Select
        If UBound(arr, 1) > 1 Then
            Dim rSeelction As Range
            Set rSeelction = Selection
            .Rows(13).Copy
            .Cells(14, 1).Resize(UBound(arr, 1) - 1, 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
            Application.CutCopyMode = False
            rSeelction.Select
        End If
        .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Dim rRow As Range
        For Each rRow In .Range("A13").Resize(UBound(arr, 1), UBound(arr, 2)).Rows
            rRow.RowHeight = 13 * (Len(rRow.Range("G1").Value) - Len(Replace(rRow.Range("G1").Value, vbCr, "")) + 1)
        Next
        Do
            If Not IsNumeric(.Cells(13 + UBound(arr, 1), 1)) Then Exit Do
            .Rows(13 + UBound(arr, 1)).Delete Shift:=xlUp
            DoEvents
        Loop
    End With
End Sub
 
Function GetArr() As Variant
    Dim sh As Worksheet
    Set sh = Sheets("СВОДКА РЭС-7")
    With sh
        .Select 'Проверка выполняется по выделенным ячейкам
        Dim y As Long
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        Dim arr As Variant
        arr = .Range(.Cells(1, 1), .Cells(y, "AJ"))
    End With
    Dim x As Integer
    Dim e As Integer
    Dim crr As Variant
    Dim brr As Variant
    'ReDim brr(0 To 0)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim yM As Long
    yM = 13
    For y = 15 To UBound(arr, 1)
        'Месяц
        If arr(y, 2) = "Ф.И.О." Then yM = y
         
        For x = 6 To UBound(arr, 2)
            Select Case arr(y, x)
            Case " "
                If Not Intersect(sh.Cells(y, x), Selection) Is Nothing Then
                    e = x
                    Do
                        Select Case arr(y, e)
                        Case " "
                            e = e + 1
                        Case Else
                            e = e - 1
                            Exit Do
                        End Select
                    Loop
                     
                    If Not dic.Exists(arr(y, 2)) Then
    '                    crr = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                        Set dic.Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
                    Else
    '                    crr = dic.Item(arr(y, 2))
    '                    crr(UBound(crr)) = arr(yM + 1, e) & " " & arr(yM, 6)
                    End If
                    crr = Array(arr(y, 5), arr(y, 2), DateValue(arr(yM + 1, x) & " " & arr(yM, 6)), DateValue(arr(yM + 1, e) & " " & arr(yM, 6)))
                    dic.Item(arr(y, 2)).Item(dic.Item(arr(y, 2)).Count) = crr
                     
    '                ReDim Preserve brr(0 To UBound(brr) + 1)
    '                brr(UBound(brr)) = Array(arr(y, 5), arr(y, 2), arr(yM + 1, x) & " " & arr(yM, 6), arr(yM + 1, e) & " " & arr(yM, 6))
                    x = e
                End If
                DoEvents
            End Select
        Next
    Next
    Dim orr As Variant
    brr = dic.Items()
    If dic.Count < 1 Then
        ReDim orr(1 To 1, 1 To 7)
    Else
        ReDim orr(1 To UBound(brr) + 1, 1 To 7)
        Dim u As Long
        Dim v As Variant
        Dim dit As Object
        For y = 0 To UBound(brr)
            u = u + 1
            orr(u, 1) = y + 1
            orr(u, 2) = brr(y).Items()(0)(0)
            orr(u, 3) = brr(y).Items()(0)(1)
            Set dit = CreateObject("Scripting.Dictionary")
            For Each v In brr(y).Items()
    '            orr(y + 1, 3) = brr(y)(1)
    '            orr(y + 1, 4) = Empty
    '            orr(y + 1, 5) = Empty
    '            orr(y + 1, 6) = Empty
                dit.Item(Replace(Format(v(2), "dd.mm.yy") & IIf(v(2) = v(3), "", " - " & Format(v(3), "dd.mm.yy")), vbCrLf, "")) = 0
            Next
            orr(y + 1, 7) = Join(dit.Keys(), ", " & vbCrLf)
        Next
    End If
    GetArr = orr
End Function
Изменено: МатросНаЗебре - 22.09.2021 09:14:09
 
МатросНаЗебре, просто шикарно, не надеялся что кто-то сможет помочь или точнее потратить свое время на помощь. Спасибо бесконечное, все просто идеально!
Страницы: 1
Наверх