Problemes impressions

[alexistak]

Bonjour a tous,
Je developpe une macro qui fait un peu de mis en page et lance le tri automatique(rien de bien mechant).
Le probleme est que lorsque je regarde les sauts de pages, j'ai 141 feuilles alors que mon tableau en couvre 8.
Comment changer ou plutot effacer ces feuilles blanches? (je sais le faire manuellement, mais la 140!!!)
Aussi, y a t'il un code pour que le saut de page corresponde a la taille du tableau. (Vous savez quand vous avez un tableau en paysage qui est coupe sur plusieurs pages).

Je vous joins le code, mais je suis pas sur que ce soit utile

Sub Main1()

'***Variables***
Dim GCCReport As Workbook                               'Workbook of report from GCC
Dim row_count As Integer                                'Counter for no of rows in GCC Report

'opens dialog box to choose report
Filename = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file")
    If Filename = False Then
        ' They pressed Cancel
        MsgBox "Stopping because you did not select a file"
        Exit Sub
    Else
    
        Workbooks.Open (Filename)
    End If

    
    row_count = RowCount

    With ActiveWorkbook.Worksheets("Sheet1")
        Rows("1:6").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR



        'adjust row heigth
        .Rows("5:20000").AutoFit
        
        'Set Borders for Cells
        .Range(Worksheets("Sheet1").Cells(5, 1), Worksheets("Sheet1").Cells(row_count, 17)).Borders.Weight = xlHairline
        .Range(Worksheets("Sheet1").Cells(5, 1), Worksheets("Sheet1").Cells(row_count, 17)).Borders.Color = RGB(0, 0, 0)
        .Range(Worksheets("Sheet1").Cells(5, 1), Worksheets("Sheet1").Cells(row_count, 17)).Borders.LineStyle = xlContinuous
        .Range("A3:Q3").Borders.LineStyle = xlContinuous
        .Range("A3:Q3").Borders.Weight = xlHairline
        .Range("A3:Q3").Borders.Color = RGB(0, 0, 0)

           Selection.UnMerge
        Rows("5:6").Select
        Selection.Delete Shift:=xlUp
        Rows("4:4").EntireRow.AutoFit
        Rows("4:4").Select
        Selection.AutoFilter
     
        ActiveWindow.ScrollColumn = 1
            End With

        With Range("A1")
    .Value = "TEST Filter"
    .WrapText = False
    End With
    
    With Range("A1")
    Range("A1").UnMerge
    End With
    

    End With
    
     
    

Call ColorUPC(5, row_count, 14)
Call SeperateUPC(5, row_count, 14)

End Sub




'~~~~~~~~~~~~~~~~~Function to count rows in GCCReports~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function RowCount() As Integer

Dim m As Integer            'Loop Counter
m = 5

Do While (ActiveWorkbook.Worksheets("Sheet1").Cells(m, 2).Value <> 0)

m = m + 1
Loop

RowCount = m - 1

End Function

'~~~~~~~~~~~~~~~~~~~Sub to color UPCs in order to separate them~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Arguments~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'start_row              specifies where to start the separation of UPCs
'row_max                row in which to end sub
'col_max                column until which background color should be changed
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'uses UPC as reference to sort


Sub ColorUPC(start_row As Integer, row_max As Integer, col_max As Integer, Optional comp_row As Integer = 2)

Dim i As Integer
i = start_row
marker = 0
'MsgBox row_max

Do While (i <= row_max)

If Worksheets("Sheet1").Cells(i, comp_row + 1) <> Worksheets("Sheet1").Cells(i - 1, comp_row + 1) Then
    
    With Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(i, 1), Worksheets("Sheet1").Cells(i, col_max)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .Color = RGB(0, 0, 0)
    End With
    
    marker = marker + 1
    'MsgBox "Marker  " & marker & " Loop counter  " & i
End If

If (marker Mod 2 = 0) Then
    Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(i, 1), Worksheets("Sheet1").Cells(i, col_max)).Interior.Color = RGB(255, 228, 181)
End If


i = i + 1
Loop

End Sub


'uses UPC as reference to sort

Sub SeperateUPC(start_row As Integer, row_max As Integer, col_max As Integer, Optional comp_row As Integer = 2, Optional del As Boolean = True)

Dim i As Integer
i = start_row
before = Worksheets("Sheet1").Cells(i - 1, comp_row)

Do While (i <= row_max)
    
    If Worksheets("Sheet1").Cells(i, comp_row) = before Then
    
    before = Worksheets("Sheet1").Cells(i, comp_row)
    
    If del = True Then
    Worksheets("Sheet1").Cells(i, comp_row).ClearContents
    End If
    
    Worksheets("Sheet1").Cells(i, comp_row).ClearContents
    
    
    
    Else
    
    before = Worksheets("Sheet1").Cells(i, comp_row)
    
    End If
    
    i = i + 1
    
Loop

End Sub
'*******************'

Merci a tous

 

[JCGL]

Re : Problemes impressions

Bonjour à tous,

Peux-tu essayer en rajoutant ceci (en gras et bleu):

End With
 
Call ColorUPC(5, row_count, 14)
Call SeperateUPC(5, row_count, 14)

[COLOR=Blue][B]With ActiveWorkbook
Columns("A:N").Select
    ActiveSheet.PageSetup.PrintArea = "$A:$N"
    ActiveWorkbook.Names.Add Name:="Print_Area", RefersToR1C1:= _
        "=OFFSET(Feuil1!C1:C14,,,COUNTA(Feuil1!C1)+2)"
End With
Range("A1").Select
Application.ScreenUpdating = True[/B][/COLOR]

End Sub

'~~~~~~~~~~~~~~~~~Function to count rows in GCCReports~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function RowCount() As Integer

et aussi ceci (pour éviter les dessins animés et accélérer un peu le code) :

Sub Main1()

'***Variables***
Dim GCCReport As Workbook                               'Workbook of report from GCC
Dim row_count As Integer                                'Counter for no of rows in GCC Report
[COLOR=Blue][B]Application.ScreenUpdating = False[/B][/COLOR]

A+

 

[alexistak]

Re : Problemes impressions

Desol emais ca ne marche pas, je vais mettre en lien le fichier utilise par la macro.
Regarde ce que ca donne comme feuille, tu comprendras mieux peut etre.
Desole pour la reponse tardive, plus d'internet, mais la je reste connecte, pour repondre a vos remarques.

Merci encore

 

[alexistak]

Re : Problemes impressions

Voila la piece jointe, la macro fais un unmerge et lange le tri automatique

 

[JCGL]

Re : Problemes impressions

Bonjour à tous,

Un essai où tu devras adapter les colonnes que tu souhaites imprimer : ici C1 à C26 soit de A à Z et pour le nombre de lignes que contient F (qui me semble être le seul totalement rempli)

A+

 

[alexistak]

Re : Problemes impressions

Merci c cool.
J'adore ce site!!!!