Not accept Print area

[gerasimos]

Hello all,

The below code is working fine

Option Explicit

Sub BuildInvoiceAll()
    Dim lR          As Long
    Dim wb          As Workbook
    Dim Ws As Worksheet, desWS As Worksheet, rng As Range
    Dim ActvSh      As Object
    Dim lView       As XlWindowView
    Dim lCntPb      As Long
    Dim lR10        As Long
    Dim i           As Long
    Dim lRowToPaste As Long

    Application.ScreenUpdating = False

    Set ActvSh = ActiveSheet
    
    Set wb = ThisWorkbook
    Set desWS = wb.Worksheets("PROFORMA")


    desWS.Select

    lView = ActiveWindow.View
    ActiveWindow.View = xlPageBreakPreview

    With desWS
        .Range("F16").Formula = "=E16*D16"
        .Rows(17 & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Delete
    End With

    With desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset()
        .Interior.ColorIndex = 2
    End With

    desWS.ListObjects("Invoice").Range.Font.Size = 21

    For Each Ws In wb.Worksheets
        If Ws.Name <> "PROFORMA" Then
            With Ws
                If Application.WorksheetFunction.CountIf(.Range("E:E"), ">0") Or Application.WorksheetFunction.CountIf(.Range("L:L"), ">0") Then
                    With desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1)
                        .Value = Ws.Name
                        .Interior.ColorIndex = 6
                        .Font.Bold = True
                    End With
                    With desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(, 4)
                        .NumberFormat = ";;;"
                        .Borders.Weight = xlThin
                        .Borders.LineStyle = xlContinuous
                        .Borders(xlInsideVertical).LineStyle = xlContinuous
                    End With
                End If
                If Application.WorksheetFunction.CountIf(.Range("E:E"), ">0") Then
                    For Each rng In .Range("E14", .Range("E" & .Rows.Count).End(xlUp))
                        If (IsNumeric(rng.Value)) And (rng.Value <> 0) Then
                            With desWS
                                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 4).Value = Array(rng.Offset(, -3), " ", rng, rng.Offset(, -1))
                            End With
                        End If
                    Next rng
                End If
                If Application.WorksheetFunction.CountIf(.Range("L:L"), ">0") Then
                    For Each rng In .Range("L14", .Range("L" & .Rows.Count).End(xlUp))
                        If (IsNumeric(rng.Value)) And (rng.Value <> 0) Then
                            With desWS
                                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 4).Value = Array(rng.Offset(, -3), " ", rng, rng.Offset(, -1))
                            End With
                        End If
                    Next rng
                End If
            End With
        End If
    Next Ws

    With desWS
        .Rows("15:10000").RowHeight = 30
        .Rows(16).Delete
        lR = .Cells(.Rows.Count, "B").End(xlUp).Row

        With .PageSetup
            .PrintArea = "A1:F" & lR
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = False
        End With

        'Only to reset UsedRange
        Set rng = .UsedRange

        lCntPb = .HPageBreaks.Count

        lR10 = 15   'last row in DATASET

        i = 2
        
        'Test last page end
        .Cells(lR + lR10 + i, "F").Value = "X"
        .PageSetup.PrintArea = "A1:F" & lR + lR10 + i

        Do While lCntPb = .HPageBreaks.Count
            i = i + 1
            With .Cells(lR + lR10 + i, "F")
                .Value = "X"
            End With
            .PageSetup.PrintArea = "A1:F" & lR + lR10 + i
        Loop

        'Find where to paste the copied table (from "DATASET")
        If .HPageBreaks(.HPageBreaks.Count).Location.Row - 1 - lR10 - 2 >= lR Then
            lRowToPaste = .HPageBreaks(.HPageBreaks.Count).Location.Row - 1 - lR10
        Else
            lCntPb = lCntPb + 1
            Do While lCntPb = .HPageBreaks.Count
                i = i + 1
                .Cells(lR + lR10 + i, "F").Value = "X"
                .PageSetup.PrintArea = "A1:F" & lR + lR10 + i
            Loop
            lRowToPaste = .HPageBreaks(.HPageBreaks.Count).Location.Row - 1 - lR10
        End If

        .Rows(lR + lR10 + 2 & ":" & lR + lR10 + i).Clear

        wb.Worksheets("DATASET").Range("A1:F" & lR10).Copy

        .Cells(lRowToPaste, "A").PasteSpecial
        .Cells(lRowToPaste, "A").Select

        With .Range(.Cells(lR + 1, "B"), .Cells(lRowToPaste - 1, "F"))
            .Borders.Weight = xlThin
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders.Color = RGB(0, 0, 0)
        End With
            .PageSetup.PrintArea = "A:F"
    End With

    ActiveWindow.View = lView
    ActvSh.Select
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Done! Invoice created."
End Sub

It is working perfect but when run on MAC it doesnt accept printarea and always trying to print with fixed width.

Can someone help? What should I change to make it work?

Thank you

Also posted at Not accept Print area

 

[gerasimos]

Here is the sample Excel Help Forum

 

[gerasimos]

I forgot. This has to do with MAC