• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Need VBA to scan dates of entries, and change adjacent cells

T

Tome9499

New Member
I am preparing a sheet to track client survey responses. My company calls back any client who submits a negative survey response. My goal is to write code that will (upon opening the workbook) scan the submit date of all surveys, and then set the survey status to "Expired" if the survey is over 2 weeks old.


My first attempt used the code below, but the Target .Value combo means that the cell needs to be manually changed/selected. Since the cell is formula driven, that is not an option.


Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo enditall

Application.EnableEvents = False

If Target.Cells.Column = 21 Then

With Target

If .Value > 336 Then

If .Offset(0, -5).Value = "" And .Offset(0, -6).Value = "New" Then

Sheet3.Unprotect Password:="1234"

.Offset(0, -9).Value = 0

.Offset(0, -8).Value = Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")

.Offset(0, -7).Value = Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")

.Offset(0, -6).Value = "Complete"

.Offset(0, -5).Value = "Expired"

Sheet3.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="1234"

End If

End If

End With

End If

enditall:

Application.EnableEvents = True

End Sub


After realizing the shortcomings of the above code, my manager came us with the solution below. The solution works, but it takes a while to cycle through all of the rngCalls. I was hoping there was a way to get the first solution to work without having to manually select the target cell above.


Private Sub Workbook_Open()

Dim j As Integer

Dim rngeAge As Variant

Dim rngeCalls() As Variant

Dim rngeInitCall() As Variant

Dim rngeCompCall() As Variant

Dim rngeStatus() As Variant

Dim rngeCategory() As Variant

Dim rngeNotes() As Variant

Dim rngeActionPlan() As Variant

Dim rngeSR() As Variant

Dim rngeAges() As Variant

If

Sheet3.Unprotect Password:="1234"

rngeAge = Sheet3.Range("L3:U5000").Value

ReDim rngeCalls(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeInitCall(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeCompCall(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeStatus(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeCategory(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeNotes(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeActionPlan(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeSR(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeAges(1 To UBound(rngeAge, 1), 1 To 1)

For j = 1 To UBound(rngeAge, 1)

If rngeAge(j, 10) >= 365 Then

If rngeAge(j, 5) = "" And rngeAge(j, 4) = "New" Then

rngeCalls(j, 1) = 0

rngeInitCall(j, 1) = Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")

rngeCompCall(j, 1) = Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")

rngeStatus(j, 1) = "Complete"

rngeCategory(j, 1) = "Expired"

rngeNotes(j, 1) = rngeAge(j, 6)

rngeActionPlan(j, 1) = rngeAge(j, 7)

rngeSR(j, 1) = rngeAge(j, 9)

rngeAges(j, 1) = rngeAge(j, 10)

Else

rngeCalls(j, 1) = rngeAge(j, 1)

rngeInitCall(j, 1) = rngeAge(j, 2)

rngeCompCall(j, 1) = rngeAge(j, 3)

rngeStatus(j, 1) = rngeAge(j, 4)

rngeCategory(j, 1) = rngeAge(j, 5)

rngeNotes(j, 1) = rngeAge(j, 6)

rngeActionPlan(j, 1) = rngeAge(j, 7)

rngeSR(j, 1) = rngeAge(j, 9)

rngeAges(j, 1) = rngeAge(j, 10)

End If

Else

rngeCalls(j, 1) = rngeAge(j, 1)

rngeInitCall(j, 1) = rngeAge(j, 2)

rngeCompCall(j, 1) = rngeAge(j, 3)

rngeStatus(j, 1) = rngeAge(j, 4)

rngeCategory(j, 1) = rngeAge(j, 5)

rngeNotes(j, 1) = rngeAge(j, 6)

rngeActionPlan(j, 1) = rngeAge(j, 7)

rngeSR(j, 1) = rngeAge(j, 9)

rngeAges(j, 1) = rngeAge(j, 10)

End If

Next j

Range("L3").Resize(UBound(rngeAge, 1), 1).Value = rngeCalls

Range("M3").Resize(UBound(rngeAge, 1), 1).Value = rngeInitCall

Range("N3").Resize(UBound(rngeAge, 1), 1).Value = rngeCompCall

Range("O3").Resize(UBound(rngeAge, 1), 1).Value = rngeStatus

Range("P3").Resize(UBound(rngeAge, 1), 1).Value = rngeCategory

Range("Q3").Resize(UBound(rngeAge, 1), 1).Value = rngeNotes

Range("R3").Resize(UBound(rngeAge, 1), 1).Value = rngeActionPlan

Range("T3").Resize(UBound(rngeAge, 1), 1).Value = rngeSR

Range("U3").Resize(UBound(rngeAge, 1), 1).Value = rngeAges

Sheet3.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="1234"

End Sub
 
Tome9499


Welcome to the Chandoo.org forums


Can you check as it looks like some code is missing in the middle where there is a lone


if


?
 
Hui,


Thanks for your post. I snipped a peice of the code out since it did not relate to the task at hand. I must have missed that lone if. The whole code is below:


Private Sub Workbook_Open()

Dim j As Integer

Dim rngeAge As Variant

Dim rngeCalls() As Variant

Dim rngeInitCall() As Variant

Dim rngeCompCall() As Variant

Dim rngeStatus() As Variant

Dim rngeCategory() As Variant

Dim rngeNotes() As Variant

Dim rngeActionPlan() As Variant

Dim rngeSR() As Variant

Dim rngeAges() As Variant


If Sheet2.AutoFilterMode = True Then

Sheet2.Unprotect Password:="password"

If Sheet2.FilterMode Then

Sheet2.ShowAllData

End If

Sheet2.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="password"

ElseIf Sheet3.AutoFilterMode = True Then

Sheet3.Unprotect Password:="password"

If Sheet3.FilterMode Then

Sheet3.ShowAllData

End If

Sheet3.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="password"


End If

Sheet3.Unprotect Password:="password"

rngeAge = Sheet3.Range("L3:U5000").Value

ReDim rngeCalls(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeInitCall(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeCompCall(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeStatus(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeCategory(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeNotes(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeActionPlan(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeSR(1 To UBound(rngeAge, 1), 1 To 1)

ReDim rngeAges(1 To UBound(rngeAge, 1), 1 To 1)

For j = 1 To UBound(rngeAge, 1)

If rngeAge(j, 10) >= 336 Then

If rngeAge(j, 5) = "" And rngeAge(j, 4) = "New" Then

rngeCalls(j, 1) = 0

rngeInitCall(j, 1) = Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")

rngeCompCall(j, 1) = Format(Now, "mm/dd/yyyy hh:mm:ss AM/PM")

rngeStatus(j, 1) = "Complete"

rngeCategory(j, 1) = "Expired"

rngeNotes(j, 1) = rngeAge(j, 6)

rngeActionPlan(j, 1) = rngeAge(j, 7)

rngeSR(j, 1) = rngeAge(j, 9)

rngeAges(j, 1) = rngeAge(j, 10)

Else

rngeCalls(j, 1) = rngeAge(j, 1)

rngeInitCall(j, 1) = rngeAge(j, 2)

rngeCompCall(j, 1) = rngeAge(j, 3)

rngeStatus(j, 1) = rngeAge(j, 4)

rngeCategory(j, 1) = rngeAge(j, 5)

rngeNotes(j, 1) = rngeAge(j, 6)

rngeActionPlan(j, 1) = rngeAge(j, 7)

rngeSR(j, 1) = rngeAge(j, 9)

rngeAges(j, 1) = rngeAge(j, 10)

End If

Else

rngeCalls(j, 1) = rngeAge(j, 1)

rngeInitCall(j, 1) = rngeAge(j, 2)

rngeCompCall(j, 1) = rngeAge(j, 3)

rngeStatus(j, 1) = rngeAge(j, 4)

rngeCategory(j, 1) = rngeAge(j, 5)

rngeNotes(j, 1) = rngeAge(j, 6)

rngeActionPlan(j, 1) = rngeAge(j, 7)
r />rngeSR(j, 1) = rngeAge(j, 9)

rngeAges(j, 1) = rngeAge(j, 10)

End If

Next j

Range("L3").Resize(UBound(rngeAge, 1), 1).Value = rngeCalls

Range("M3").Resize(UBound(rngeAge, 1), 1).Value = rngeInitCall

Range("N3").Resize(UBound(rngeAge, 1), 1).Value = rngeCompCall

Range("O3").Resize(UBound(rngeAge, 1), 1).Value = rngeStatus

Range("P3").Resize(UBound(rngeAge, 1), 1).Value = rngeCategory

Range("Q3").Resize(UBound(rngeAge, 1), 1).Value = rngeNotes

Range("R3").Resize(UBound(rngeAge, 1), 1).Value = rngeActionPlan

Range("T3").Resize(UBound(rngeAge, 1), 1).Value = rngeSR

Range("U3").Resize(UBound(rngeAge, 1), 1).Value = rngeAges

Sheet3.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="password"

End Sub
 
You must log in or register to reply here.
Back
Top