Sub Colombus_Start()
'
' Colombus_Start Macro
'
Dim columnBrand As String: columnBrand = "A"
Dim columnGroup As String: columnGroup = "B"
Dim columnReference1 As String: columnReference1 = "C"
Dim columnReference2 As String: columnReference2 = "D"
Dim columnProduct As String: columnProduct = "E"
Dim columnImage As String: columnImage = "F"
Dim columnRangeReference1 As String: columnRangeReference1 = "C:C"
Dim counterRow As Long
Dim counterReference As Long
Dim strReference As String
Dim strImage As String
Dim intLastRow As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
intLastRow = Range("C" & Rows.Count).End(xlUp).Row
'Sort by Reference & Custom Sort by Size
With ActiveWorkbook.ActiveSheet.Sort
With .SortFields
.Clear
'Sort by Reference
.Add Key:=Range("C3:C" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sort by Colour
.Add Key:=Range("G3:G" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sort by Custom Range > Sizes
.Add Key:=Range("J3:J" & intLastRow), CustomOrder:="TU, SS, XS, S, M, L, EL, XL"
End With
.SetRange Range("A3:V" & intLastRow)
.Apply
End With
'Inserts SubTotals
Range("A3:V" & intLastRow).Select
Selection.Subtotal GroupBy:=3, Function:=xlSum, _
TotalList:=Array(14, 15, 16, 17, 18, 19, 20, 21, 22)
'Loop to change row height according to the number of rows per reference. This assures that the image will fit.
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
strReference = Cells(counterRow, columnReference1)
counterReference = Application.WorksheetFunction.CountIf(Range(columnRangeReference1), strReference)
If Left(Cells(counterRow, columnReference1), 5) = "Total" Then
Rows(counterRow).RowHeight = 23
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Range(Cells(counterRow, "A"), Cells(counterRow, "K")).Merge
Range(Cells(counterRow, "A"), Cells(counterRow, "K")).VerticalAlignment = xlCenter
ElseIf Left(Cells(counterRow, columnReference1), 5) = "REF 1" Then
Rows(counterRow).RowHeight = 48
ElseIf counterReference = 1 Then
Rows(counterRow).RowHeight = 90
ElseIf counterReference = 2 Then
Rows(counterRow).RowHeight = 45
ElseIf counterReference = 3 Then
Rows(counterRow).RowHeight = 30
ElseIf counterReference = 4 Then
Rows(counterRow).RowHeight = 23
ElseIf counterReference = 5 Then
Rows(counterRow).RowHeight = 18
ElseIf counterReference = 6 Then
Rows(counterRow).RowHeight = 15
End If
Next counterRow
'Deletes redundant images & merges cells with identical values
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
If Cells(counterRow, columnReference1) = Cells(counterRow + 1, columnReference1) Then
On Error Resume Next
Range(Cells(counterRow, columnBrand), Cells(counterRow + 1, columnBrand)).Merge
Range(Cells(counterRow, columnGroup), Cells(counterRow + 1, columnGroup)).Merge
Range(Cells(counterRow, columnReference1), Cells(counterRow + 1, columnReference1)).Merge
Range(Cells(counterRow, columnReference2), Cells(counterRow + 1, columnReference2)).Merge
Range(Cells(counterRow, columnProduct), Cells(counterRow + 1, columnProduct)).Merge
Range(Cells(counterRow, columnImage), Cells(counterRow + 1, columnImage)).Merge
End If
Next counterRow
'Gets image URL, finds image on server and inserts in in the active cell
For counterRow = Cells(Rows.Count, columnImage).End(xlUp).Row To 1 Step -1
On Error Resume Next
strImage = Cells(counterRow, columnImage).Value
Cells(counterRow, columnImage).Activate
Selection = ActiveSheet.Shapes.AddPicture(strImage, False, True, ActiveCell.Left + 4, ActiveCell.Top + 4, 86, 70)
Next counterRow
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveWorkbook.Save
End Sub