Cells Format and subtotals with VBA

Question

I have created a VBA macro to give the format to Sheet in excel and create some subtotals.

It works, but has a lot of room for improvement.

Right now it takes very long.

I know that using Matrix the processing time could be reduced to milliseconds.

Sub justsubttotals()
Sheets("Produktionsplan").Select
'Delete previous format
Range("A4:I1000").Select
With Selection.Interior
    .Pattern = xlNone
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = xlAutomatic
    .TintAndShade = 0
    .Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlHairline
End With
'I define 3 start variables with the first row of the matrix (per default it  always starts in row 4).
 primero = 4
 fin = 4
 contar = 4
   'Identify how many rows are in the file
    Finalrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    For j = 4 To Finalrow
If Cells(j, 1) = 0 And contar <= Finalrow Then
Cells(j, 1).Select
Selection.EntireRow.Select
Selection.Delete Shift:=xlUp
j = j - 1
contar = contar + 1
Else
contar = contar + 1
End If
Next

inicio = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Este inicio lo guardo para la parte de los subtotales
inicio2 = inicio
 'Este inicio si es para los formatos
 inicio = inicio + 1




 For i = 4 To inicio

For j = primero To inicio
    If Cells(primero, 4) = Cells(fin + 1, 4) Then
        fin = fin + 1
    Else
        j = inicio
    End If
Next


'Based on the description of column 2, I know which colour to assign

 If Cells(primero, 2) = "B. Rück RH" Or Cells(primero, 2) = "B. 7 OB RH" Then
    Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.699981688894314
        .PatternTintAndShade = 0
    End With

 ElseIf Cells(primero, 2) = "B. Rück LH" Or Cells(primero, 2) = "B. 7 OB LH" Then
    Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.499981688894314
        .PatternTintAndShade = 0
    End With

 ElseIf Cells(primero, 2) = "B. 7 SAMS Center  " Then
    Range("A" & primero & ":I" & fin).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 8771461
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

 ElseIf Cells(primero, 2) = "B. 7 SAMS LH  " Then
    Range("A" & primero & ":I" & fin).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 8771461
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

 ElseIf Cells(primero, 2) = "B. 7 SAMS RH  " Then
    Range("A" & primero & ":I" & fin).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 8771461
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

 ElseIf Cells(primero, 2) = "B. 634 RH/LH  " Then
    Range("A" & primero & ":I" & fin).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 6723891
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

 ElseIf Cells(primero, 2) = "B. Vor RH" Then
    Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.699981688894314
        .PatternTintAndShade = 0
    End With

ElseIf Cells(primero, 2) = "B. Vor LH" Then
     Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.699981688894314
        .PatternTintAndShade = 0
    End With

ElseIf Cells(primero, 2) = "Porsche RH" Then
    Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

ElseIf Cells(primero, 2) = "Porsche LH" Then
     Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.399993896298105
        .PatternTintAndShade = 0
    End With

ElseIf Cells(primero, 2) = "Audi RH" Then
     Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
    .ThemeColor = xlThemeColorDark2
    .TintAndShade = -9.99786370433668E-02
        .TintAndShade = 0.699981688894314
        .PatternTintAndShade = 0
    End With

ElseIf Cells(primero, 2) = "Audi LH" Then
     Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent3
    .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With


    Else
    Range("A" & primero & ":I" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End If



    Range("A" & primero & ":I" & fin).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With

primero = fin + 1
Next



 '************************************************
   'I create the subtotals
 '************************************************
  primero = 4
  fin = 4
  inicio = inicio2

For i = 4 To inicio

For j = primero To inicio
    If Cells(primero, 4) = Cells(fin + 1, 4) Then
        fin = fin + 1
    Else
        j = inicio
    End If
Next
If fin > primero Then
    Rows(fin + 1 & ":" & fin + 1).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    inicio = inicio + 1
    Range("H" & fin + 1).Select
    Cells(fin + 1, 8).Value = "=Sum(H" & primero & ":H" & fin & ")"
    Range("H" & fin + 1).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
Else
        Range("H" & fin).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True

End If

  primero = fin + 1
  Next

  '************************************************
  'I use the formula of another sheet
  '************************************************

Sheets("RuestenMatrix").Select
Range("J1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Produktionsplan").Select
Range("J4:J810").Select
ActiveSheet.Paste

   '************************************************
   'Once again I use the formula of another sheet
   '************************************************
Sheets("Pause Zeit").Select
Range("K4:K5").Select
Selection.Copy
Sheets("Produktionsplan").Select
Range("K4").Select
ActiveSheet.Paste
Range("K5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("K5:K810")
Range("K5:K810").Select

   '************************************************
    'One more time I use the formula of another sheet
   '************************************************
 Cells(4, 13).Select
Sheets("Pause Zeit").Select
Range("M4:P5").Select
Selection.Copy
Sheets("Produktionsplan").Select
ActiveSheet.Paste
Range("M5:P5").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("M5:P872")
Range("M5:P872").Select
Range("M4").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
Selection.Font.Bold = True


End Sub

The reason it is taking so long is all the `.Select` they are unneeded 98% of the time and one should reference the cell directly. See here, for more info: http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros — Scott Craner, Feb 02 '17 at 14:37
Also use `Application.ScreenUpdating = False` to reduce the time of updating the screen.Also, instead of using `Borders(xlEdgeLeft)` and `Borders(xlEdgeTop)` and the other two, just use `BorderAround` — Shai Rado, Feb 02 '17 at 14:43
Another suggestion would be to decide some pre-defined styles and use subs (with range as an input parameter) to apply that formatting. It would follow DRY principle and also make the code far more maintainable. — Zerk, Feb 02 '17 at 14:45
Instead of writing `Finalrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row`, and cycling each row to delete it with `Selection.EntireRow.Select`, `Selection.Delete Shift:=xlUp`, do just `ActiveSheet.Range(ActiveSheet.Cells(4, 1), ActiveSheet.Cells(ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row, 1)).EntireRow.Delete (xlShiftUp)`. This deletes all the rows between (4,1) and the last row of the column A. — Eugene, Feb 02 '17 at 14:54
Is it possible to create a sheet exactly the way you want it formatted, then hide it, and then copy it to a new worksheet when you need a copy of it? It will be done in a fraction of a second. — John Muggins, Feb 02 '17 at 20:33

Cells Format and subtotals with VBA

0 Answers0