我创建了一个VBA宏，将格式设置为excel中的Sheet并创建一些小计。
它有效，但还有很大的改进空间。
现在需要很长时间。
我知道使用Matrix可以将处理时间缩短到几毫秒。
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