BrandynBlaze
New Member
- Joined
- Sep 20, 2012
- Messages
- 29
So I don't know what's going wrong with my code, it's just designed to automate a formatting task that I repeat often at work. I've put comments in for all the subroutines to explain them but basically it finds the used range, borders it, formats the headers, uses select case to find specific instances of headers and assigns color properties to them, then parses the headers column and assigns the same color value to empty cells or gray to cells that have values. Right now it's throwing an error for a type mismatch in the SelectCellColor() subroutine even though I know it's the correct type.
I'm sure this code could be improved greatly and maybe a couple of subroutines could be combined but I wanted them as separate as possible when I was debugging it. It's also the first program I've written in VB and haven't programmed much of anything in several years so I'm definitely open to any suggestions for improving it beyond just getting it running.
Thanks!
I'm sure this code could be improved greatly and maybe a couple of subroutines could be combined but I wanted them as separate as possible when I was debugging it. It's also the first program I've written in VB and haven't programmed much of anything in several years so I'm definitely open to any suggestions for improving it beyond just getting it running.
Thanks!
Code:
Public LstRw As Long, LstCol As Long
Public HeaderTheme As String, HeaderTint As Double
Sub FindUsedRange()
'Uses find function to set used cell range
LstRw = Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
LstCol = Cells.Find(What:="*", SearchOrder:=xlColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column
Call BorderUsedRange
End Sub
Sub BorderUsedRange()
'Borders Used Cell Range
ActiveSheet.Cells.ClearFormats
With Range(Cells(1, 1), Cells(LstRw, LstCol))
.Borders.Weight = xlThin
.Font.Bold = False
End With
Range(Cells(1, 1), Cells(1, LstCol)).Font.Bold = True
Call FormatTopRow
End Sub
Sub FormatTopRow()
'Selects top row and gives it thick borders with thin borders inbetween.
Range(Cells(1, 1), Cells(1, LstCol)).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Call FindHeaders
End Sub
Sub FindHeaders()
'Parses Headers and uses Select Case to assign Color Values for specific Cases
Range("A1").Select
Dim i As Integer
Dim Header As String
For i = 1 To LstCol
Header = ActiveCell.Value
Select Case Header
Case "FEA":
HeaderTheme = "xlThemeColorAccent2"
HeaderTint = 0.6
Call SelectCellColor
Case "SUN":
MsgBox "Found Sun"
End Select
ActiveCell.Offset(0, 1).Select
Next i
End Sub
Sub SelectCellColor()
'Assigns color to Header
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = HeaderTheme
.TintAndShade = HeaderTint
.PatternTintAndShade = 0
End With
MsgBox "Going to FormatColumn"
Call FormatColumn
End Sub
Sub FormatColumn()
'Parses column and assigns header color to cells with values, gray to cells that are blank
Dim j As Integer
For j = 2 To LstRw
Cells(j, ActiveCell.Column).Activate
If ActiveCell.Value = "" Then
With Range(Cells(j, i)).Value.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = HeaderTheme
.TintAndShade = HeaderTint
.PatternTintAndShade = 0
End With
Else
With Range(Cells(j, i)).Value.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1 'Haven't assigned color values for gray yet
.TintAndShade = 1
.PatternTintAndShade = 0
End With
End If
Next j
End Sub