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
Merci 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
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
'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