I am having difficulty with my code. It runs fine, but it takes ages to
complete its task. Is there a way to clean this up? Basic information is
that cell C4 is a starting date (m-yyyy) and C5 is the duration in months.
Also, does anyone have thoughts on wiping all the formating (color, values,
borders, but NOT formulas) of every column after the last date in row 6?

Thanks!

Sub DatesWithQuarters()
Dim X As Long, Col As Long, Row As Long
Dim StartDate As Variant, Duration As Variant
Col = 5
Row = 6
StartDate = Range("c4")
Duration = Range("c5")
If IsDate(StartDate) And Len(Duration) 0 And _
Not Duration Like "*[!0-9]*" Then
If Duration 0 Then
With Cells(Row, Col).Resize(, Duration + Int(Duration / 3))
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
StartDate = CDate(StartDate)
For X = 0 To Duration - 1
Cells(Row, Col).NumberFormat = "mmm-yy"
Cells(Row, Col).Value = DateAdd("m", X, StartDate)
Cells(Row, Col).Select
If Month(DateAdd("m", X, StartDate)) Mod 3 = 0 And X 0 Then
Col = Col + 1
Cells(Row, Col).NumberFormat = "@"
Cells(Row, Col).Value = Format(DateAdd("m", X, _
StartDate), "\Qq-yy")
With Cells(Row, Col)
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6724095
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End If
Col = Col + 1
Next
End If
End If
Dim myRange As Range
Set myRange = Worksheets("Data Inputs").Range("Rng")
With myRange
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End With
End Sub
--
Hugo

Might be easier to just send your file to my address below along with a copy
of this msg and before/after examples

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"Hugo" wrote in message
...
I am having difficulty with my code. It runs fine, but it takes ages to
complete its task. Is there a way to clean this up? Basic information is
that cell C4 is a starting date (m-yyyy) and C5 is the duration in months.
Also, does anyone have thoughts on wiping all the formating (color,
values,
borders, but NOT formulas) of every column after the last date in row 6?

Thanks!

Sub DatesWithQuarters()
Dim X As Long, Col As Long, Row As Long
Dim StartDate As Variant, Duration As Variant
Col = 5
Row = 6
StartDate = Range("c4")
Duration = Range("c5")
If IsDate(StartDate) And Len(Duration) 0 And _
Not Duration Like "*[!0-9]*" Then
If Duration 0 Then
With Cells(Row, Col).Resize(, Duration + Int(Duration / 3))
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10092543
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
StartDate = CDate(StartDate)
For X = 0 To Duration - 1
Cells(Row, Col).NumberFormat = "mmm-yy"
Cells(Row, Col).Value = DateAdd("m", X, StartDate)
Cells(Row, Col).Select
If Month(DateAdd("m", X, StartDate)) Mod 3 = 0 And X 0 Then
Col = Col + 1
Cells(Row, Col).NumberFormat = "@"
Cells(Row, Col).Value = Format(DateAdd("m", X, _
StartDate), "\Qq-yy")
With Cells(Row, Col)
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6724095
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End If
Col = Col + 1
Next
End If
End If
Dim myRange As Range
Set myRange = Worksheets("Data Inputs").Range("Rng")
With myRange
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End With
End Sub
--
Hugo