removing hard coding from code

[bearsfan]

I received some super help from Sandy in putting this code together. The new
task I have been wrangling with is removing the hard coding from this so that
if a user wanted to input a new row/column it won't break the spreadsheet.
I've tried replacing all the row and columns with variable names but it still
seems to break everytime I do. I'm sure it is something right under my nose.
Your help is greatly appreciated.

Regards,
BearFan

Option Explicit

Private Sub Worksheet_Change(ByVal target As Range)
On Error Resume Next
Dim DateRange, RTDateRange, TestDurationRange, ADBDurationRange As Range
Dim DRCol As Range
Dim ReleaseDate, TestFill, ADBFill As Range
Dim TestValue, ADBValue As Integer
Dim ADBDurCol, TDurCol, RTDurCol, PMapStartCol As String


Application.enableevents = False

'Set the Ranges
Set DateRange = Range("R6", Cells("6", Columns.Count).End(xlToLeft))
Set RTDateRange = Range("Q7", Cells(Rows.Count, "Q").End(xlUp))
Set TestDurationRange = Range("P7", Cells(Rows.Count, "P").End(xlUp))
Set ADBDurationRange = Range("O7", Cells(Rows.Count, "O").End(xlUp))
Set DRCol = Cells("6", Columns.Count).End(xlToLeft)

'Check if any RTDateRange, TestDurationRange, ADBDurationRange
'were changed
If Intersect(target, RTDateRange) Is Nothing Or _
Intersect(target, TestDurationRange) Is Nothing Or _
Intersect(target, ADBDurationRange) Is Nothing Then

'If the target row of RTDateRange is not empty
If Not Cells(target.Row, "Q") = Empty Then

'If the target row of RTDateRange is not a date then display the
message box,
'clear the target row and exit the sub
If Not IsDate(Cells(target.Row, "Q")) And Not Cells(target.Row, "Q") =
Empty Then
MsgBox "The date you entered is not a valid date format, please
retry", vbExclamation
With Range("Q" & target.Row, Intersect(DRCol.EntireColumn,
target.EntireRow).Address)
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
Application.enableevents = True
Exit Sub

'If the target row of column "N" (ADB Duration) or column "O" (Test
Duration)
'is not a date then display the message box ,clear the target row and
exit the sub
ElseIf Not IsNumeric(Cells(target.Row, "O")) Or Not
IsNumeric(Cells(target.Row, "P")) Then
MsgBox "The number you entered is not a valid number format, please
retry", vbExclamation
With Range("O" & target.Row, Intersect(DRCol.EntireColumn,
target.EntireRow).Address)
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
Application.enableevents = True
Exit Sub
End If
Else 'If the target row of RTDateRange is empty clear the target row
With Range("R" & target.Row, Intersect(DRCol.EntireColumn,
target.EntireRow).Address)
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
Application.enableevents = True
Exit Sub
End If

'Clear the target row from column "Q" to the intersect of the target row
and
' the last date in the headers row for update
With Range("R" & target.Row, Intersect(DRCol.EntireColumn,
target.EntireRow).Address)
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With

'***************Find match and enter "Rel" into proper cell***************
For Each ReleaseDate In DateRange
If ReleaseDate = Cells(target.Row, "Q") Then
With Cells(target.Row, ReleaseDate.Column)
.Value = "Rel"
.Interior.ColorIndex = 4
End With
Exit For
End If
Next ReleaseDate

'If there is no match diplay message box and exit Sub Routine
If Not ReleaseDate = Cells(target.Row, "Q") Then
MsgBox "Your date does not match a date in the header, please check
your date and re-enter", vbExclamation
Cells(target.Row, "Q").ClearContents
Application.enableevents = True
Exit Sub
End If

'Set the testfill variable = to the "Rel" cell's address
Set TestFill = Cells(target.Row, ReleaseDate.Column)

'Clear the cells from column "Q" to the cell to the left of the "Rel" cell
With Range("R" & target.Row, Cells(target.Row, (ReleaseDate.Column - 1)))
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With

'*******************************Fill in Test
cells******************************
For TestValue = -1 To (Cells(target.Row, "P").Value * -1) Step -1
If TestFill.Address = TestFill.Offset(0, TestValue).Address Then Exit
For
'With testfill offset by 0 rows and the testvalue counter value
With TestFill.Offset(0, TestValue)
'If TestFill.Offset(0, TestValue) address is not <= column 16 (or
column P)
'then fill in values
If Not .Column <= 16 Then
.Value = "T"
.Interior.ColorIndex = 34
Else ' If it is... display the message box and exit sub
MsgBox "Your test duration has gone past your first date check
your values!", vbExclamation
With Range("R" & target.Row, Cells(target.Row,
(ReleaseDate.Column - 1)))
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
Application.enableevents = True
Cells(target.Row, "P").ClearContents
Exit Sub
End If
End With
Next TestValue ' goto the next testvalue counter

'Set ADBFill = the "Rel" cell offset by 0 rows
'and the testvalue counter when it ended plus 1 if it does not
' equal the target row & column "P"
If Not TestFill.Offset(0, TestValue + 1) = Cells(target.Row, "R") Then
Set ADBFill = TestFill.Offset(0, TestValue + 1)
Else 'if it does...
'display message box and exit
MsgBox "You have reached the beginning of your date header and have no
more room to " & _
"place ADB durations into the row; check your values and try again.",
vbExclamation
Application.enableevents = True
Exit Sub
End If

With Range("R" & target.Row, Cells(target.Row, TestFill.Offset(0,
TestValue).Column))
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With


'******************************Fill in ADB cells******************************
For ADBValue = -1 To (Cells(target.Row, "O").Value * -1) Step -1
If ADBFill.Address = ADBFill.Offset(0, ADBValue).Address Then Exit For

'With ADBFill offset by 0 rows and the ADBvalue counter value
With ADBFill.Offset(0, ADBValue)

'If ADBFill.Offset(0, ADBValue) address is not <= column 16 (or
column P)
'then fill in values
If Not .Column <= 16 Then
.Value = "ADB"
.Interior.ColorIndex = 36
Else ' If it is... display the message box and exit sub
MsgBox "Your ADB duration has gone past your first date check
your values!", vbExclamation
With Range("R" & target.Row, Cells(target.Row,
(ReleaseDate.Column - 1)))
.ClearContents
.Interior.ColorIndex = xlColorIndexNone
End With
Application.enableevents = True
Cells(target.Row, "O").ClearContents
Exit Sub
End If
End With
Next ADBValue
Application.enableevents = True
Exit Sub
End If
Application.enableevents = True
End Sub


Sub enable()
Application.enableevents = True
End Sub

 

[Charles Chickering]

Quick comment for you, when you dim multiple things with one dim statement
you must specify what they are dimmed as or they are dimmed as a variant.
For Example in your statement:
Dim DateRange, RTDateRange, TestDurationRange, ADBDurationRange As Range
DateRange, RTDateRange and TestDurationRange are all getting dimmed as a
variant
to make them all ranges you must specify range for each and every one of them:
Dim DateRange As Range, RTDateRange As Range, _
TestDurationRange As Range, ADBDurationRange As Range

It would be great if we could dim multiple variables like you did but that's
not how it works.

 

[Sandy]

Hey Bearsfan, try this out

place this just after the first "Application.EnableEvents = False" (and
before the comment Set the ranges)

If ActiveSheet.Columns.Insert Or ActiveSheet.Rows.Insert Then
Application.EnableEvents = True
Exit Sub
End If

By the way, still working on helping you with your last questions, give
me another day or two...

r/Sandy

 

[bearsfan]

Thanks for the advice Charles. I'm still learning VBA and have been receiving
great help from all the professionals on this website. I modified my code
accordingly.

BearsFan

 

[Sandy]

Yes Charles that was my bad on that one.... thanks for catching that

Sandy

 

[bearsfan]

Sandy,

That was so easy and it worked! I definitely figured the solution would be
much more difficult. As I said before, "I can't thank you enough".

BearsFan