'~~~~~~Sub to adjust row heigth and column width of Full Backup Report for Non ABS~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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")
'adjust column width
.Columns("A").ColumnWidth = 10
.Columns("B").ColumnWidth = 10
.Columns("C").ColumnWidth = 10
.Columns("D").ColumnWidth = 10
.Columns("E").ColumnWidth = 10
.Columns("F").ColumnWidth = 5
.Columns("G").ColumnWidth = 5
.Columns("H").ColumnWidth = 5
.Columns("I").ColumnWidth = 8
.Columns("L").ColumnWidth = 25
.Columns("M").ColumnWidth = 8
.Columns("N").ColumnWidth = 25
.Columns("O").ColumnWidth = 20
.Columns("P").ColumnWidth = 7
'adjust row heigth
.Rows("4:20000").AutoFit
'Set Borders for Cells
.Range(Worksheets("Sheet1").Cells(4, 1), Worksheets("Sheet1").Cells(row_count, 17)).Borders.Weight = xlHairline
.Range(Worksheets("Sheet1").Cells(4, 1), Worksheets("Sheet1").Cells(row_count, 17)).Borders.Color = RGB(0, 0, 0)
.Range(Worksheets("Sheet1").Cells(4, 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)
End With
Call ColorUPC(5, row_count, 14)
Call SeperateUPC(5, row_count, 14)
Call PrintSetup(65, 2)
'Call Rangement(1)
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
Sub PrintSetup(resize As Double, sheet As Integer)
Dim Run As Boolean
Run = Application.Dialogs(xlDialogPrinterSetup).Show
If Run = False Then
MsgBox "Stopping Print Setup since no printer was chosen"
Exit Sub
Else
'************Page Setup***************
With Workbooks("GCC Violation Report Filter Macro.xls").Worksheets(sheet).PageSetup
'.PaperSize = xlPaperA3
.Zoom = resize
.Orientation = xlLandscape
.TopMargin = 0.5
.BottomMargin = 0.5
.RightMargin = 0.5
.LeftMargin = 0.5
'.PrintArea = "A1:AR10"
End With
Application.Dialogs(xlDialogPrintPreview).Show
End If
' '************Print Dialog***********
' ActiveWorkbook.Worksheets(1).PrintOut
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
'*******************'
