Страницы: 1
RSS
Перенос данных из одного листа по дням
 
Добрый день, помогите разобраться  :cry: .Есть 100 машин, выезжают ежедневно , из программы можно выгрузить файл , но на все единицы (прикреплю пример) эти все машины нужно разнести по листам на каждую единицу (файл прикреплю) и еще, при выгрузке общий расход топлива , а нужно разделение на холостой и рабочий  8-0 . возможно ли это сделать по формуле? или только в ручную? Помогите  :(  
 
Вариант макросом. Рекомендую тестировать на копиях, а не на файлах, которые используются в работе.
Код
Sub Разнести()
    Const sNAME = "Реестр транспортных средств 26.05.2021.xls"
    Dim wb As Workbook
    On Error Resume Next
        Set wb = Workbooks(sNAME)
    On Error GoTo 0
    If wb Is Nothing Then
        MsgBox "Не найдена книга " & vbCrLf & sNAME, vbCritical
    Else
        Dim Application_Calculation As Long
        Application_Calculation = Application.Calculation
        Application.Calculation = xlCalculationManual
    
        Dim y As Long
        Dim u As Long
        Dim arr As Variant
        With ActiveSheet
            y = .Cells(.Rows.Count, "D").End(xlUp).Row
            arr = .Range(.Cells(1, 1), .Cells(y, "AH"))
        End With
        
        Dim sh As Worksheet
        For y = 6 To UBound(arr, 1)
            Set sh = Nothing
            On Error Resume Next
            Set sh = wb.Sheets(arr(y, 4))
            On Error GoTo 0
            If sh Is Nothing Then
                wb.Sheets.Add after:=wb.Sheets(wb.Sheets.Count)
                Set sh = wb.Sheets(wb.Sheets.Count)
                sh.Name = arr(y, 4)
            End If
            With sh
                u = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                
                'Здесь задайте номера столбцов из каких в какие нужно перенести данные.
                .Cells(u, "A").Value = arr(y, 5)
                .Cells(u, "B").Value = arr(y, 6)
                '...
            End With
        Next
        
        Application.Calculation = Application_Calculation
    End If
End Sub
Изменено: МатросНаЗебре - 01.06.2021 13:19:30
Страницы: 1
Наверх