Страницы: 1
RSS
Перенос данных из ячеек одного документа в ячейки другого документа c определенным шагом. VBA, Макрос VBA
 
Всем приветик ;)
Подскажите, как грамотно перенести рабочие часы в смену(т.е 8, либо 7 и т.д) для каждого сотрудника из документа "График" в документ "Табель" с помощью макроса:qstn:
Основная сложность в том, что в док. "Табель" в календаре смен присутствует промежуточный столбец "Итого отработано за..." его надо перешагнуть.

Во вложении прилагаю оба упомянутых файла.

Порадуйте неопытную меня)
Спасибки заранее)

---------------
:*
 
Код
Sub Main()
    Dim shG As Worksheet: Set shG = Workbooks("график.xlsm").Worksheets("график")
    Dim shT As Worksheet: Set shT = Workbooks("Табельный.xlsm").Worksheets("Табель")
     
    Dim dic As Object:    Set dic = GetDic(shG)
    OutDic shT, dic
End Sub
'
Function GetDic(sh As Worksheet) As Object
    Dim y As Long
    Dim x As Byte
    Dim a As Variant
    Dim g As Variant
    Dim g15 As Variant
    Dim g31 As Variant
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
        a = .Range(.Cells(1, 1), .Cells(y, 5))
        x = .Cells(4, .Columns.Count).End(xlToLeft).Column
        g = .Range(.Cells(1, [g1].Column), .Cells(y, .Columns.Count).End(xlToLeft))
    End With
    Dim dic As Object:    Set dic = CreateObject("Scripting.Dictionary")
    Dim arr3(1 To 1, 1 To 3) As Variant
    For y = 6 To UBound(a, 1)
        If a(y, 1) Then
            For x = 1 To 3
                arr3(1, x) = a(y, x ^ 2 - 2 * x + 2)
            Next
            ReDim g15(1 To 1, 1 To 15)
            ReDim g31(1 To 1, 16 To 31)
            For x = 1 To UBound(g, 2)
                If IsNumeric(g(4, x)) Then
                    If g(4, x) > 0 Then
                        If g(4, x) <= 15 Then
                            g15(1, g(4, x)) = g(y + 2, x)
                        ElseIf g(4, x) <= 31 Then
                            g31(1, g(4, x)) = g(y + 2, x)
                        End If
                    End If
                End If
            Next
            dic.Item(a(y, 1)) = Array(arr3, g15, g31)
        End If
    Next
    If dic.Exists("") Then dic.Remove ("")
    Set GetDic = dic
End Function
'
Sub OutDic(sh As Worksheet, dic As Object)
    With sh
        Dim x As Byte
        Dim y As Long
        Dim yMax  As Long
        Dim i As Long
        Dim a As Variant
     
        yMax = .Cells(.Rows.Count, 1).End(xlUp).Row
        y = 19
        For i = 1 To dic.Count
            If y > 19 Then .Rows("19:20").Copy .Cells(y, 1) 'Заполнение новых строк.
            a = dic.Items()(i - 1)
            .Cells(y + 0, 1).Resize(1, 3).Value = a(LBound(a) + 0)
            .Cells(y + 1, 4).Resize(1, 15).Value = a(LBound(a) + 1)
            .Cells(y + 1, 20).Resize(1, 16).Value = a(LBound(a) + 2)
            y = y + 2
        Next
        Do
            If y > yMax Then Exit Do
            For x = 1 To 3
                .Cells(y, x).Resize(2, 1).ClearContents
            Next
            y = y + 2
        Loop
    End With
End Sub
 
Безумно благодарна :*

При выполнении кода у меня возникает ошибка "Несоответствие типов (ошибка 13)" на 25 шаге:
Код
....
If a(y, 1) Then
....


Пробовала менять тип переменных- безрезультатно. Где "зарыто" решение?
Спасибо)
 
Код
If Not IsEmpty(a(y, 1)) Then
Попробуйте так.
 
В этом случае макрос отрабатывает частично- происходит перенос всех данных по сотрудникам, кроме часов :(
 
На файлах, которые были в первом сообщении, вроде работает.
Вы не меняли структуру данных? Вроде добавления строк и пр.
 
Цитата
МатросНаЗебре написал:
На файлах, которые были в первом сообщении, вроде работает.
Также проверил, всё отработало, ошибки не появилось, решил, что я чего-то не понимаю и убежал из темы.
 
Цитата
МатросНаЗебре написал:
Вы не меняли структуру данных? Вроде добавления строк и пр.

В рабочем документе, где я запускаю макрос, имеется около 60 сотрудников. Это основное отличие от приложенных в теме образцов.
 
Цитата
EleeSha написал:
В рабочем документе, где я запускаю макрос, имеется около 60 сотрудников.
Возможно, есть ещё отличия, о которых Вы не подозреваете. Удалите все персональные данные (замените Иванова на Пупкина и т. д.) и выложите пример, воспроизводящий ошибку, возможно, быстрее получите помощь.
 
Спасибо за совет :)  Во вложении прикрепила документ - образец графика, в котором я работаю и откуда тянутся данные в макросе.
Искренне надеюсь , это поможет ускорить поиск решения :*
Изменено: EleeSha - 24.02.2020 12:59:14
 
Актуальный график = Актуальный график работы ??????
 
Цитата
EleeSha написал:
Это основное отличие от приложенных в теме образцов.
Как раз это и не основное отличие от образцов.
Вас ведь прямо спросили:
Цитата
МатросНаЗебре написал:
Вы не меняли структуру данных? Вроде добавления строк и пр.
В присланном Вами "актуальном графике" несколько графиков, между которыми вставлены другие таблицы с совершенно иной структурой. Естественно, разработанный выше код для такого примера работать не будет. К сожалению, я не вижу легкого решения. В структуре "актуального графика" сплошной треш и вытащить из него данные довольно трудоёмкая и длительная процедура (длительная в смысле времени на разработку алгоритма), может кто и возьмется...
Если убрать лишнее, то всё работает (во вложении, код из поста № 2 не корректировал)
 
Цитата
aequit написал: В присланном Вами "актуальном графике" несколько графиков, между которыми вставлены другие таблицы с совершенно иной структурой.
Прошу прощения, по своему поняла значения слов "структура данных" :oops:

Цитата
сожалению, я не вижу легкого решения.
Верно понимаю, что основная сложность в настройке выбора и переносе всех сотрудников из документа "Актуальный график" вместо жесткой привязки к строкам документа?
Может есть у кого мыслишки как это реализовать :qstn:
 
МатросНаЗебре, (да и любой, кто хочет и может) подскажите, пожалуйста, как правильно видоизменить скрипт, чтобы не было жесткой привязки к строкам, из которых тянутся данные по сотрудникам?
Т.е. если строка в"Актуальный график" содержит слова "ФИО/Должность", то следующая строка является первой, откуда начинается перенос в "Табель". И так до первой пустой строки. После чего цикл повторяется, пока в документе с графиком не останется строк с "ФИО/Должность"  

Всем :*
 
EleeSha,
Цитата
если строка в"Актуальный график" содержит слова "ФИО/Должность",
В макросе находим начало диапазона BeginRow и конец EndRow,
в цикле переносите этот диапазон куда нужно
Код
Sub iFIO()
Dim FoundCell As Range
Dim FAdr As String
Dim BeginRow As Long
Dim EndRow As Long
    Set FoundCell = Columns("B:D").Find("ФИО/Должность", , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      BeginRow = FoundCell.Row + 2
      Do
       EndRow = Range("B" & BeginRow).End(xlDown).Row
       'первый диапазон строка 19 - строка 51 (потом 174-185) и т.д.
       'переносите этот диапазон куда нужно
       Set FoundCell = Columns("B:D").FindNext(FoundCell)
       BeginRow = FoundCell.Row + 2
      Loop While FoundCell.Address <> FAdr
     End If
End Sub
 
Kuzmich, как я понимаю, тут осуществляется только поиск диапазона. В исходном макросе для переноса активно используется массив данных. В виду своей неопытности еще не осознаю, как вшить ваш макрос, чтобы в дальнейшем работал перенос. Можете подсказать?  :sceptic: 🙏
 
Цитата
как вшить ваш макрос, чтобы в дальнейшем работал перенос.
Макрос в стандартный модуль. Нашли начало диапазона BeginRow и конец EndRow
дальше копируете нужный диапазон
Код
Range("B" & BeginRow & ":CV" & EndRow).Copy

и вставляете куда нужно.
 
Дополнил код Kuzmichа. Проверяйте. И не бегайте по форумам, начните хоть что-то делать самостоятельно.
Скрытый текст


P.s. Необъявленный кросс
Изменено: aequit - 29.02.2020 20:41:03
Страницы: 1
Наверх