![]() |
Help with mess of code
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 |
Help with mess of code
|
All times are GMT +1. The time now is 02:12 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com