Подготовить отчёт Яндекс Такси и сделать PDF по каждому ФИО

Код

Sub YandexTaxiPdfByFio()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long, headerRow As Long
    Dim colMap As Object, dict As Object
    Dim keepHeaders As Variant
    Dim i As Long, j As Long, k As Long
    Dim nameCol As Long, sumCol As Long
    Dim savePath As String, fileName As String
    Dim fio As String, val As Double, key As Variant, ch As Variant
    Dim outArr() As Variant, infoArr As Variant
    Dim outCols As Long, dataRows As Long, srcCol As Long
    Dim invalidChars As Variant, lastVisible As Long, pdfCount As Long

    Set ws = ActiveSheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ws.Cells.UnMerge
    ws.Rows("3:5").Delete Shift:=xlUp
    headerRow = 4
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(headerRow, ws.Columns.Count).End(xlToLeft).Column

    keepHeaders = Array("Дата заказа", "Кому заказали: ФИО", _
                        "Точка посадки", "Пункт назначения", _
                        "Сумма без НДС", "Сумма НДС", "Сумма с НДС", _
                        "Центр затрат")
    Set colMap = CreateObject("Scripting.Dictionary")
    For j = 1 To lastCol
        For i = LBound(keepHeaders) To UBound(keepHeaders)
            If Trim$(CStr(ws.Cells(headerRow, j).Value)) = keepHeaders(i) Then
                If Not colMap.Exists(keepHeaders(i)) Then colMap.Add keepHeaders(i), j
                Exit For
            End If
        Next i
    Next j
    For i = LBound(keepHeaders) To UBound(keepHeaders)
        If Not colMap.Exists(keepHeaders(i)) Then
            MsgBox "Не найден столбец: " & keepHeaders(i), vbCritical
            Application.ScreenUpdating = True
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next i

    outCols = UBound(keepHeaders) - LBound(keepHeaders) + 1
    dataRows = lastRow - headerRow
    If dataRows > 0 Then
        ReDim outArr(1 To dataRows, 1 To outCols)
        For i = 1 To dataRows
            For k = 0 To outCols - 1
                srcCol = colMap(keepHeaders(k))
                outArr(i, k + 1) = ws.Cells(headerRow + i, srcCol).Value
            Next k
        Next i
    End If

    infoArr = ws.Range("A1:H2").Value
    ws.Cells.Clear
    ws.Range("A1:B2").Value = infoArr
    For k = 0 To outCols - 1
        ws.Cells(4, k + 1).Value = keepHeaders(k)
    Next k
    If dataRows > 0 Then ws.Range("A5").Resize(dataRows, outCols).Value = outArr

    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    If lastRow < 5 Then lastRow = 5
    lastCol = outCols
    With ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
        .WrapText = True
        .VerticalAlignment = xlTop
    End With
    ws.Columns("A").ColumnWidth = 12
    ws.Columns("B").ColumnWidth = 28
    ws.Columns("C").ColumnWidth = 40
    ws.Columns("D").ColumnWidth = 40
    ws.Columns("E:G").ColumnWidth = 14
    ws.Columns("H").ColumnWidth = 18
    Application.ScreenUpdating = True
    ws.Rows("1:" & lastRow).EntireRow.AutoFit
    Application.ScreenUpdating = False
    With ws.Range(ws.Cells(4, 1), ws.Cells(4, lastCol))
        .Font.Bold = True
        .Interior.Color = RGB(178, 178, 178)
        .HorizontalAlignment = xlCenter
    End With
    ws.Range(ws.Cells(4, 1), ws.Cells(lastRow, lastCol)).Borders.LineStyle = xlContinuous

    ' После пересборки столбцы идут в порядке keepHeaders
    nameCol = 2
    sumCol = 5

    Set dict = CreateObject("Scripting.Dictionary")
    For i = 5 To lastRow
        fio = Trim$(CStr(ws.Cells(i, nameCol).Value))
        If Len(fio) > 0 Then
            If Not dict.Exists(fio) Then dict.Add fio, 0#
            val = 0
            If IsNumeric(ws.Cells(i, sumCol).Value) Then val = CDbl(ws.Cells(i, sumCol).Value)
            dict(fio) = dict(fio) + val
        End If
    Next i

    savePath = ActiveWorkbook.Path
    If Len(savePath) = 0 Then savePath = Environ$("USERPROFILE") & "\Desktop"
    savePath = savePath & "\PDF_Output\"
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath

    With ws.PageSetup
        .Orientation = xlLandscape
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintTitleRows = "$4:$4"
    End With

    Application.ScreenUpdating = True
    invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    For Each key In dict.Keys
        If ws.AutoFilterMode Then ws.AutoFilterMode = False
        ws.Range(ws.Cells(4, 1), ws.Cells(lastRow, lastCol)).AutoFilter Field:=nameCol, Criteria1:=CStr(key)
        ws.Cells(3, sumCol - 1).Value = "Total Sum For: " & key
        ws.Cells(3, sumCol - 1).Font.Bold = True
        ws.Cells(3, sumCol).Value = dict(key)
        ws.Cells(3, sumCol).NumberFormat = "#,##0.00"
        lastVisible = lastRow
        For i = lastRow To 5 Step -1
            If ws.Rows(i).Hidden = False Then
                lastVisible = i
                Exit For
            End If
        Next i
        ws.PageSetup.PrintArea = ws.Range(ws.Cells(1, 1), ws.Cells(lastVisible, lastCol)).Address
        fileName = "Report_" & CStr(key) & "_" & Format(Now, "yyyy-mm-dd")
        For Each ch In invalidChars
            fileName = Replace(fileName, CStr(ch), "_")
        Next ch
        On Error Resume Next
        ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath & fileName & ".pdf", _
            Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
        If Err.Number = 0 Then pdfCount = pdfCount + 1
        Err.Clear
        On Error GoTo 0
        ws.Cells(3, sumCol - 1).ClearContents
        ws.Cells(3, sumCol).ClearContents
        If ws.AutoFilterMode Then ws.AutoFilterMode = False
    Next key

    Application.DisplayAlerts = True
    MsgBox "Создано PDF: " & pdfCount & vbCrLf & savePath, vbInformation
    On Error Resume Next
    Shell "explorer """ & savePath & """", vbNormalFocus
End Sub

Связанные члены API

Range.Value Workbook.Path Application.ScreenUpdating Application.DisplayAlerts Worksheet.AutoFilterMode