Categorize Age Groups

[adam]

Hi anyone,

Im trying to figure out a worksheet event code that would copy the age groups and paste them in the column

Suppose If I write the date 21/1/2011 in column "C" of the sheet "Sur" how could I write a worksheet event code that would copy all the "DF" under 5 to column "D" and all the DF above 5 to the column "E" as the same as with the "DHF.

In short the date 21/1/2011 contains 2 "DF" above 5 years which I want the code to get them copied to the "E" as 2 and below 5 years to the column "D" as 1.

I hope I've made my question clear.

Any help on this would be kindly appreciated.

Thanks in advance.

I've attached the workbook for further reference.

[Don Wells]

Hello Adam
The solution which I offer has some constraints:

• The data on the Reg worksheet must be sorted by date as you provided in your sample

• Data validation should be used to ensure that only 'DF' or 'DHF' are used in the Compl column.

• Abbreviations must not be used for 'Years' in the Age column. '27 yrs' will calculate as 'under 5 years'.

    Place this first piece of code in the "Sur" worksheet module.

Code: Select all

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 3 Then
    Call PopulateOnDate(Target)
  End If
End Sub

Place this second piece of code in a Standard module.

Code: Select all

Option Explicit

Sub PopulateOnDate(Target As Range)
Const DF_Col = 4
Const DHF_Col = 6
Dim DoI As Date 'Date of Interest
Dim TRoI As Long 'Target Row of Interest
Dim SRoI As Long 'Source Row of Interest
Dim TCOI As Long 'Target Column of interest
Dim TWS As Worksheet
Dim SWS As Worksheet
Dim CTR As Long
Dim FoundDate As Date
Dim Compl As String
Dim Age As String
Dim Years As Long

  DoI = Target
  TRoI = Target.Row
  Set TWS = Sheets("Sur")
  Set SWS = Sheets("Reg")
  
  'Clear the Target
  For CTR = 4 To 7 ' columns D to G
    TWS.Cells(TRoI, CTR).ClearContents
  Next CTR
  
  'Find the last instance of the Date of interest on the Reg sheet
  With SWS
    SRoI = .Cells(.Rows.Count, 2).End(xlUp).Row
    If .Cells(SRoI, 2) = "Date" Then
      MsgBox Target & " does not exist in the database.", vbExclamation
      GoTo ExitHandler
    End If
    FoundDate = .Cells(SRoI, 2)
    Do While FoundDate <> DoI
      If FoundDate < DoI Then
        MsgBox Target & " does not exist in the database.", vbExclamation
        GoTo ExitHandler
      End If
      SRoI = SRoI - 1
      If .Cells(SRoI, 2) = "Date" Then
        MsgBox Target & " does not exist in the database.", vbExclamation
        GoTo ExitHandler
      End If
      FoundDate = .Cells(SRoI, 2)
    Loop
    
    'Process each entry for the Date of Interest
    Do While FoundDate = DoI
    
      'Identify the first col of the DF or DHF group
      Compl = .Cells(SRoI, 8)
      Select Case Compl
      Case "DF"
        TCOI = DF_Col
      Case "DHF"
        TCOI = DHF_Col
      End Select
      
      'Increment the Target column of interest
      Age = Trim(.Cells(SRoI, 5))
      With TWS
        If LCase(Right(Age, 5)) <> "years" Then
          .Cells(TRoI, TCOI) = .Cells(TRoI, TCOI) + 1
        Else
          Years = Val(Left(Age, Len(Age) - 6))
          If Years < 5 Then
            .Cells(TRoI, TCOI) = .Cells(TRoI, TCOI) + 1
          Else
            .Cells(TRoI, TCOI + 1) = .Cells(TRoI, TCOI + 1) + 1
          End If
        End If
      End With
      
      SRoI = SRoI - 1
      On Error Resume Next
      FoundDate = .Cells(SRoI, 2)
      If Err Then
        On Error GoTo 0
        Exit Do
      End If
    Loop
  End With
  
ExitHandler:

End Sub

[adam]

Thanks for the Help Don. I do really appreciate it & will keep in mind your suggested recommendations.

If I may ask more; my concern now is how could I make the worksheet event code to copy each single date from the series of dates from the sheet "Reg" to the sheet "Sur" so that the user does not have to write the date manually.

Any help on this would be kindly appreciated.

[Don Wells]

Try clicking the Refresh button on the Sur worksheet of the attached workbook.

[adam]

This replaces all previously recommended code.

Don, does this mean the second code posted by you should be used instead of both the worksheet event code and the first standard module code?

[Don Wells]

This replaces all previously recommended code.

Don, does this mean the second code posted by you should be used instead of both the worksheet event code and the first standard module code?

Yes. See revised post.

[Don Wells]

FWIW
    You will get about a five fold improvement in speed if you disable the screen updating while the code is running.

Code: Select all

Option Explicit

Sub Populate_Sur()
  Application.ScreenUpdating = False  '~~~~~~~~~~~~~~~~~~~~ Add this Line
          |
 A whole bunch of code has been removed for clarity
          |
  Application.ScreenUpdating = True  '~~~~~~~~~~~~~~~~~~~ Add this Line Also
End Sub
    

[HansV]

Code: Select all

 A whole bunch of code has been removed for clarity

That also increases speed drastically!

[Don Wells]

That also increases speed drastically!

Reduces speed!!    You can only imagine how it reduces effectiveness.

[adam]

Thanks for the help and recommendations Don & Hans. I do really appreciate it.