Option Explicit
Sub xlShadeRowCol(Optional ShadeOptions As Boolean = False)
Dim ColorNum As Long
Dim First As Long
Dim Last As Long
Dim MsgbxTitle As String
Dim Increment As Long
Dim ProcOpns As String
Dim RowOrCol As String
Dim TempIn As String
Dim xlSheetName As String
Dim xlSheetRtn As Integer
MsgbxTitle = "Row and Column Shading"
GetRowOrCol:
RowOrCol = InputBox("row or col?", MsgbxTitle)
Select Case LCase(RowOrCol)
Case vbNullString, "end", "quit"
Exit Sub
Case "col"
If ShadeOptions = False Then
Call xlShadeCols
Exit Sub
End If
Case "row"
If ShadeOptions = False Then
Call xlShadeRows
Exit Sub
End If
Case Else
MsgBox "invalid input", vbCritical
GoTo GetRowOrCol
End Select
ColorNum = 35
First = 1
Last = 0
Increment = 2
xlSheetName = ActiveSheet.Name
GetOptions:
ProcOpns = _
InputBox("enter optional arg # OR the word 'shade' to shade " & _
"with current values:" & vbCrLf & _
"0 exit/quit without any shading" & vbCrLf & _
"1 sheet other than activesheet" & vbCrLf & _
"2 first row or col other than 1" & vbCrLf & _
"3 last row or col other than last populated" & vbCrLf & _
"4 shading increment other than 2 (every other)" & vbCrLf & _
"5 color other than light green", MsgbxTitle, "shade")
Select Case ProcOpns
Case "shade"
Select Case LCase(RowOrCol)
Case Is = "col"
Call xlShadeCols(xlSheetName, First, Last, Increment, ColorNum)
Case Is = "row"
Call xlShadeRows(xlSheetName, First, Last, Increment, ColorNum)
End Select
Case Is = "0", vbNullString, ""
Exit Sub
Case Is = "1"
GetxlSheetName:
xlSheetName = InputBox("sheet name?" & vbCrLf & _
"enter blank/cancel to go back to previous prompt", MsgbxTitle)
If xlSheetName = "" Then
GoTo GetOptions
End If
Select Case xlSheetExists(xlSheetName)
Case Is = 0
MsgBox xlSheetName & " is not a valid sheet in the active workbook", _
vbCritical, MsgbxTitle
GoTo GetxlSheetName
Case Is = 1
Case Is = 2
MsgBox xlSheetName & " is a CHARTSHEET in the active workbook" & vbCrLf & _
"chart sheets can not be shaded", vbCritical, MsgbxTitle
GoTo GetxlSheetName
End Select
GoTo GetOptions
Case Is = "2"
GetFirst:
TempIn = InputBox("first row or col?", MsgbxTitle)
If TempIn = "" Then GoTo GetOptions
First = TempIn
If First < 1 Then
MsgBox "values < 1 not allowed", vbCritical
GoTo GetFirst
End If
GoTo GetOptions
Case Is = "3"
GetLast:
TempIn = InputBox("last row or col?", MsgbxTitle)
If TempIn = "" Then GoTo GetOptions
Last = TempIn
If Last < 1 Then
MsgBox "values < 1 not allowed", vbCritical
GoTo GetLast
End If
GoTo GetOptions
Case Is = "4"
GetIncrement:
TempIn = InputBox("increment?", MsgbxTitle)
If TempIn = "" Then GoTo GetOptions
Increment = TempIn
If Increment < 1 Then
MsgBox "values < 1 not allowed", vbCritical
GoTo GetIncrement
End If
GoTo GetOptions
Case Is = "5"
ColorNum = InputBox("color number?", MsgbxTitle)
GoTo GetOptions
Case Else
MsgBox "invalid choice", vbCritical
GoTo GetOptions
End Select
End Sub
Sub xlShadeRows( _
Optional xlSheetName As String, _
Optional FirstRow As Long = 1, _
Optional LastRow As Long, _
Optional Increment As Long = 2, _
Optional ColorNum As Long = 35)
Dim I As Long
Dim Row As Long
Dim xlsheet As Worksheet
If xlSheetName = vbNullString Then xlSheetName = ActiveSheet.Name
On Error GoTo ErrorHandling_BadSheetName
Set xlsheet = Worksheets(xlSheetName)
If LastRow = 0 Then LastRow = xlLastRow(xlsheet.Name)
Row = FirstRow - 1
For I = FirstRow To LastRow
Row = Row + 1
If Row Mod Increment = 0 Then
With xlsheet.Rows(Row).Interior
.ColorIndex = ColorNum
.Pattern = xlSolid
End With
End If
Next I
If xlsheet.Name <> ActiveSheet.Name Then
MsgBox "row shading of " & xlsheet.Name & " complete.", vbInformation
End If
Exit Sub
ErrorHandling_BadSheetName:
MsgBox "sheetname passed to xlShadeRows is not valid", vbCritical
End Sub
Sub xlShadeCols( _
Optional xlSheetName As String, _
Optional FirstCol As Long = 1, _
Optional LastCol As Long, _
Optional Increment As Long = 2, _
Optional ColorNum As Long = 35)
Dim Col As Long
Dim I As Long
Dim xlsheet As Worksheet
If xlSheetName = vbNullString Then xlSheetName = ActiveSheet.Name
On Error GoTo ErrorHandling_BadSheetName
Set xlsheet = Worksheets(xlSheetName)
If LastCol = 0 Then LastCol = xlLastCol(xlsheet.Name)
Col = FirstCol - 1
For I = FirstCol To LastCol
Col = Col + 1
If Col Mod Increment = 0 Then
With xlsheet.Columns(Col).Interior
.ColorIndex = ColorNum
.Pattern = xlSolid
End With
End If
Next I
If xlsheet.Name <> ActiveSheet.Name Then
MsgBox "column shading of " & xlsheet.Name & " complete.", vbInformation
End If
Exit Sub
ErrorHandling_BadSheetName:
MsgBox "sheetname passed to xlShadeCols is not valid", vbCritical
End Sub
Function xlLastRow(Optional WorksheetName As String) As Long
If WorksheetName = vbNullString Then
WorksheetName = ActiveSheet.Name
End If
With Worksheets(WorksheetName)
xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _
xlWhole, xlByRows, xlPrevious).Row
End With
End Function
Function xlLastCol(Optional WorksheetName As String) As Long
If WorksheetName = vbNullString Then
WorksheetName = ActiveSheet.Name
End If
With Worksheets(WorksheetName)
xlLastCol = .Cells.Find("*", .Cells(1), xlFormulas, _
xlWhole, xlByColumns, xlPrevious).Column
End With
End Function
Sub xlUnShadeAll(Optional WorksheetName As String)
Dim xlRange As Range
Set xlRange = Selection
If WorksheetName = vbNullString Then
WorksheetName = ActiveSheet.Name
End If
Worksheets(WorksheetName).Cells.Select
Selection.Interior.ColorIndex = xlNone
xlRange.Select
End Sub
Function xlSheetExists(SheetName As String, Optional WorkBookName As String) As Integer
Dim xlobj As Object
If WorkBookName = vbNullString Then WorkBookName = ActiveWorkbook.Name
On Error Resume Next
Set xlobj = Workbooks(WorkBookName).Worksheets(SheetName)
If Err = 0 Then
xlSheetExists = 1
Exit Function
End If
On Error Resume Next
Set xlobj = Workbooks(WorkBookName).Charts(SheetName)
If Err = 0 Then
xlSheetExists = 2
Exit Function
End If
xlSheetExists = 0
End Function
|