Help with mess of code

H

Hugo

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
 
D

Don Guillett

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
(e-mail address removed)
Hugo said:
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
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Border formatting row of cells 22
Help with macro 1
How to rewrite this code? (Second half) 1
How to rewrite this code? (first half) 1
Compare 2 excel sheets -Error Checking of entered names 1
Formatting stop when reach blank cell 6
Loops through Sheets but doesn't work. 5
Trying to format a cell with a border 7

Top