Predict Date of Enlistment

[HTSCF Fareha]

Many thanks Dave, this seems to work just fine!

Is there a layman's explanation of the date function here?

.Cells(LastRow + 1, Cnt) = frmEnlistment.txtSoldierNumber.Value
                        .Range(.Cells(3, Cnt + 1), .Cells(LastRow + 1, Cnt + 1)).NumberFormat = "@"
                        .Cells(LastRow + 1, Cnt + 1) = CStr(frmEnlistment.txtEnlistmentDate.Text)

Really like to know how the .NumberFormat = "@" works.

It picks up any leap year faults by putting up the prompt message, whether this is a leap year date in the past or the future. To keep things tidy, is there a way to ensure that a total of six numerals are used (**/**/****)?




Many thanks to Paul too!

Sorry if the two posts became crossed, this was not my intention.

I agree that separating the three parts kind of makes sense. Is there such a thing as having "tabs" on a UserForm that might facilitate this?

[Paul_Hossler]

If you still want to use a single Userform, then the MultiPage control would be your best bet

Capture.JPG


Personally, I still think 3 separate, single purpose user forms would be cleaner, but that just the way I like to do things

The WB form in the attachment doesn't do anything except open with the workbook

[HTSCF Fareha]

Remove the location and 1900 problem by replacing the date entry and retrieval with strings. Dave

I've noticed that some of the existing dates get "changed" to numbers as soon as a new entry is made. Is this part of the serial number / string and how do we get the existing dates back into dates?

Thanks!

Steve

[HTSCF Fareha]

If you still want to use a single Userform, then the MultiPage control would be your best bet

Capture.JPG


Personally, I still think 3 separate, single purpose user forms would be cleaner, but that just the way I like to do things

The WB form in the attachment doesn't do anything except open with the workbook

Thanks for this Paul, I'll check this out to see how this works.

[Dave]

Steve...

.Range(.Cells(3, Cnt + 1), .Cells(LastRow + 1, Cnt + 1)).NumberFormat = "@"

The code sets the whole range of "dates" to text. As I pm'd, you will need to remove and then re-enter the previous "dates" that have been converted to numbers by this reset. You can add these 2 checks to ensure "date" format before entry...

Dim SplitDate As Variant    
    SplitDate = Split(frmEnlistment.txtEnlistmentDate.Text, "/")
    If SplitDate(0) <> 2 Or SplitDate(1) <> 2 Or SplitDate(2) <> 4 Then
    MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
    Exit Sub
    End If
    If InStr(frmEnlistment.txtEnlistmentDate.Text, "/") <> 3 Or _
      InStr(frmEnlistment.txtEnlistmentDate.Text, "/") <> 6 Then
      MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
    Exit Sub
    End If

Thanks Paul for your assistance and I agree your approach would separate the 3 activities of the form: adding battalions and regiments, entering soldiers, and searching for soldiers entered. Also, the "predicting" part of the search, only presents the dates, the soldier numbers are used to determine if the soldier exists and if not what known enlisted soldier dates are displayed. Thanks also to those that contributed to the related thread. Dave

[Dave]

Whoops. This line of code above was wrong. Dave

If Len(SplitDate(0)) <> 2 Or Len(SplitDate(1)) <> 2 Or Len(SplitDate(2)) <> 4 Then

[HTSCF Fareha]

I too would like to extend my thanks to all who assisted in some way, this is ver y much appreciated.

A special thanks goes out to #Dave who has been an absolute legend in sticking with me on this project.

I've put the code in the previous two posts as suggested (hopefully), but it still keeps throwing up the message "Enter date in dd/mm/yyyy format!"
I convinced it must be me!

Private Sub cmbEnter_Click()
    ' Input known soldier's number and enlistment date to add to selected Regiment / Battalion
    Dim LastRow As Integer, LastCol As Integer, Cnt As Integer, Cnt2 As Integer
    Dim Sht As Worksheet, SortRange As Range
    Dim SplitDate As Variant

    If frmEnlistment.lboRegiment.ListIndex = -1 Then
        MsgBox "Select Regiment!", vbExclamation + vbOKOnly, "Soldier Enlistment"
        Exit Sub
    End If
    If frmEnlistment.lboBattalion.ListIndex = -1 Then
        MsgBox "Select Battalion!", vbExclamation + vbOKOnly, "Soldier Enlistment"
        Exit Sub
    End If
    If Not IsNumeric(frmEnlistment.txtSoldierNumber.Value) Or _
       frmEnlistment.txtSoldierNumber.Text = vbNullString Then
        MsgBox "Enter Soldier Number!", vbExclamation + vbOKOnly, "Soldier Enlistment"
        Exit Sub
    End If
    If Not IsDate(frmEnlistment.txtEnlistmentDate.Text) Or _
       frmEnlistment.txtEnlistmentDate.Text = vbNullString Then
        MsgBox "Enter date in Day-Month-Year format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
        Exit Sub
    End If
    
    SplitDate = Split(frmEnlistment.txtEnlistmentDate.Text, "/")
    If Len(SplitDate(0)) <> 2 Or Len(SplitDate(1)) <> 2 Or Len(SplitDate(2)) <> 4 Then
    MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
    Exit Sub
    End If
    If InStr(frmEnlistment.txtEnlistmentDate.Text, "/") <> 3 Or _
      InStr(frmEnlistment.txtEnlistmentDate.Text, "/") <> 6 Then
      MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
    Exit Sub
    End If
    
    For Each Sht In ThisWorkbook.Sheets
        If frmEnlistment.lboRegiment.List(frmEnlistment.lboRegiment.ListIndex) = Sht.Name Then
            With Sheets(Sht.Name)
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            For Cnt = 1 To LastCol
            If Sheets(Sht.Name).Cells(1, Cnt) = frmEnlistment.lboBattalion.List(frmEnlistment.lboBattalion.ListIndex) Then
            LastRow = .Cells(.Rows.Count, Cnt).End(xlUp).Row
            For Cnt2 = 3 To LastRow
            If CInt(Sheets(Sht.Name).Cells(Cnt2, Cnt)) = CInt(frmEnlistment.txtSoldierNumber.Value) Then
            frmEnlistment.txtEnlistmentDate.Text = vbNullString
            MsgBox "Soldier number already exists!", vbExclamation + vbOKOnly, "Soldier Enlistment"
            frmEnlistment.txtEnlistmentDate.Text = CStr(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1))
            Exit Sub
            End If
            Next Cnt2
            .Cells(LastRow + 1, Cnt) = frmEnlistment.txtSoldierNumber.Value
            .Range(.Cells(3, Cnt + 1), .Cells(LastRow + 1, Cnt + 1)).NumberFormat = "@"
            .Cells(LastRow + 1, Cnt + 1) = CStr(frmEnlistment.txtEnlistmentDate.Text)
            Exit For
            End If
            Next Cnt
            Exit For
            End With
        End If
    Next Sht
    
    With Sheets(Sht.Name)
        Set SortRange = .Range(.Cells(3, Cnt), .Cells(LastRow + 1, Cnt + 1))
    End With
    With SortRange
        .Sort Key1:=Cells(3, Cnt), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
    
    frmEnlistment.txtSoldierNumber.Text = vbNullString
    frmEnlistment.txtEnlistmentDate.Text = vbNullString
    frmEnlistment.lboRegiment.ListIndex = -1
    frmEnlistment.lboBattalion.ListIndex = -1
End Sub



Private Sub cmbEnquiry_Click()

    Dim LastRow As Integer, LastCol As Integer, Cnt As Integer, Cnt2 As Integer
    Dim Sht As Worksheet, SortRange As Range, Flag As Boolean, RowSpot As Integer
    Dim SplitDate As Variant

    ' Enlistment date query
    ' If number already exists, then show it and the date in txtEstEnlistmentDateResult
    ' If number doesn't exist, then show 4 nearest numbers and their date either side in lboEnlistBefore and lboEnlistAfter

    If frmEnlistment.lboRegiment.ListIndex = -1 Then
        MsgBox "Select Regiment!", vbExclamation + vbOKOnly, "Soldier Enlistment"
        Exit Sub
    End If
    If frmEnlistment.lboBattalion.ListIndex = -1 Then
        MsgBox "Select Battalion!", vbExclamation + vbOKOnly, "Soldier Enlistment"
        Exit Sub
    End If
    If frmEnlistment.txtSoldierNumberEnq.Text = vbNullString Then
        MsgBox "Input Soldier Number to Query!", vbExclamation + vbOKOnly, "Soldier Enlistment"
        Exit Sub
    End If
    
    frmEnlistment.lboEnlistBefore.Clear
    frmEnlistment.lboEnlistAfter.Clear
    frmEnlistment.txtEstEnlistmentDateResult.Text = vbNullString

    SplitDate = Split(frmEnlistment.txtEnlistmentDate.Text, "/")
    If Len(SplitDate(0)) <> 2 Or Len(SplitDate(1)) <> 2 Or Len(SplitDate(2)) <> 4 Then
    MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
    Exit Sub
    End If
    If InStr(frmEnlistment.txtEnlistmentDate.Text, "/") <> 3 Or _
      InStr(frmEnlistment.txtEnlistmentDate.Text, "/") <> 6 Then
      MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
    Exit Sub
    End If
    
    For Each Sht In ThisWorkbook.Sheets
        If frmEnlistment.lboRegiment.List(frmEnlistment.lboRegiment.ListIndex) = Sht.Name Then
        With Sheets(Sht.Name)
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For Cnt = 1 To LastCol
        If Sheets(Sht.Name).Cells(1, Cnt) = frmEnlistment.lboBattalion.List(frmEnlistment.lboBattalion.ListIndex) Then
        LastRow = .Cells(.Rows.Count, Cnt).End(xlUp).Row
        For Cnt2 = 3 To LastRow
        If CInt(Sheets(Sht.Name).Cells(Cnt2, Cnt)) = CInt(frmEnlistment.txtSoldierNumberEnq.Value) Then
        If Left(CDate(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1)), 4) <> 1900 Then
        frmEnlistment.txtEstEnlistmentDateResult.Text = Format(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), "dd/mm/yyyy")
        Else
        frmEnlistment.txtEstEnlistmentDateResult.Text = CStr(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1))
        End If
        Flag = True
        Exit For
        Else
        If CInt(Sheets(Sht.Name).Cells(Cnt2, Cnt)) < CInt(frmEnlistment.txtSoldierNumberEnq.Value) Then
        RowSpot = Cnt2
        End If
        End If
        Next Cnt2
                        
                        If Not Flag Then
                            frmEnlistment.txtEstEnlistmentDateResult.Text = "Enlistment Date Not Known!"
                            With frmEnlistment.lboEnlistBefore
                                .ColumnCount = 2
                                .ColumnWidths = "80;60"
                                .Clear
                            End With
                            With frmEnlistment.lboEnlistAfter
                                .ColumnCount = 2
                                .ColumnWidths = "80;60"
                                .Clear
                            End With
                            
                            On Error Resume Next
                            With frmEnlistment.lboEnlistBefore
                                .AddItem
                                If RowSpot >= 6 Then
                                    .List(0, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot - 3, Cnt))
                                    .List(0, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot - 3, Cnt + 1))
                                Else
                                    .List(0, 0) = vbNullString
                                    .List(0, 1) = vbNullString
                                End If
                                .AddItem
                                If RowSpot >= 5 Then
                                    .List(1, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot - 2, Cnt))
                                    .List(1, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot - 2, Cnt + 1))
                                Else
                                    .List(1, 0) = vbNullString
                                    .List(1, 1) = vbNullString
                                End If
                                .AddItem
                                If RowSpot >= 4 Then
                                    .List(2, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot - 1, Cnt))
                                    .List(2, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot - 1, Cnt + 1))
                                Else
                                    .List(2, 0) = vbNullString
                                    .List(2, 1) = vbNullString
                                End If
                                .AddItem
                                If RowSpot >= 3 Then
                                    .List(3, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot, Cnt))
                                    .List(3, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot, Cnt + 1))
                                Else
                                    .List(3, 0) = vbNullString
                                    .List(3, 1) = vbNullString
                                End If
                            End With
                            If RowSpot = 0 Then
                                RowSpot = 2
                            End If
                            With frmEnlistment.lboEnlistAfter
                                .AddItem
                                .List(0, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot + 1, Cnt))
                                .List(0, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot + 1, Cnt + 1))
                                .AddItem
                                .List(1, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot + 2, Cnt))
                                .List(1, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot + 2, Cnt + 1))
                                .AddItem
                                .List(2, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot + 3, Cnt))
                                .List(2, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot + 3, Cnt + 1))
                                .AddItem
                                .List(3, 0) = CStr(Sheets(Sht.Name).Cells(RowSpot + 4, Cnt))
                                .List(3, 1) = CStr(Sheets(Sht.Name).Cells(RowSpot + 4, Cnt + 1))
                            End With
                            On Error GoTo 0
                        End If
                        Exit For
                    End If
                Next Cnt
            End With
        End If
    Next Sht
End Sub

[Dave]

My apologies Steve. I also screwed up the Instr part of the code... I posted before I had tested thoroughly. My bad. This seems to work. Also note the change in code order. HTH. Dave

If InStr(1, frmEnlistment.txtEnlistmentDate.Text, "/", 1) <> 3 Or
 _InStr(4, frmEnlistment.txtEnlistmentDate.Text, "/", 1) <> 6 Then
MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
Exit Sub
End If


SplitDate = Split(frmEnlistment.txtEnlistmentDate.Text, "/")
If Len(SplitDate(0)) <> 2 Or Len(SplitDate(1)) <> 2 Or Len(SplitDate(2)) <> 4 Then
MsgBox "Enter date in dd/mm/yyyy format!", vbExclamation + vbOKOnly, "Soldier Enlistment"
Exit Sub
End If

[HTSCF Fareha]

Sorry, Dave, but the first two lines are throwing up a syntax error.

If InStr(1, frmEnlistment.txtEnlistmentDate.Text, "/", 1) <> 3 Or
 _InStr(4, frmEnlistment.txtEnlistmentDate.Text, "/", 1) <> 6 Then

[Dave]

That just posted wrong... so I messed it up on edit. It should be this...

If InStr(1, frmEnlistment.txtEnlistmentDate.Text, "/", 1) <> 3 Or _
InStr(4, frmEnlistment.txtEnlistmentDate.Text, "/", 1) <> 6 Then

Dave

[HTSCF Fareha]

That's fixed it. Many thanks, Dave!

Final part is to provide totals in TextBox 'txtTotalRecords' when a Regiment is selected (total number of Soldiers of all the Battalions added together for that Regiment) or if a Regiment and a Battalion are selected (total number of Soldiers of the selected Battalion).

I've added a Dim of Total (Integer) to the Private Sub cmbEnter_Click() and cobbled together the following, which I've placed after the Input checks and before any input is performed :-

' Count total number of Soldier entries of selected Regiment
    
    If frmEnlistment.lboRegiment.ListIndex = 1 Then
    Total = .Cells(.Rows.Count, Cnt).End(xlUp).Row
    txtTotalRecords.Total
    
    ' Count total number of Soldier entries of selected Battalion
    
    ElseIf frmEnlistment.lboRegiment.ListIndex = 1 And frmEnlistment.lboBattalion.ListIndex <> 1 Then
    Total = .Cells(.Rows.Count, Cnt).End(xlUp).Row
    txt.TotalRecords.Total
    End If

This is not having the desired effect of providing any total.

Steve

[Dave]

This should do it until the "Incidentally, not all soldier numbers were made up purely of numerals, some were prefixed with "G/", "G", "L/", "M", "M2", "T/", "T2/", "T3/", "SE/" or "SS/" to describe but a few" problem arises.
Replace this code...

Private Sub lboRegiment_Click()Dim Sht As Worksheet, LastCol As Integer, Cnt As Integer
Dim LastRow As Integer, Total As Integer
frmEnlistment.lboBattalion.Clear
For Each Sht In ThisWorkbook.Sheets
If frmEnlistment.lboRegiment.List(frmEnlistment.lboRegiment.ListIndex) = Sht.Name Then
With Sheets(Sht.Name)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
For Cnt = 1 To LastCol
If Sheets(Sht.Name).Cells(1, Cnt).Value <> vbNullString Then
frmEnlistment.lboBattalion.AddItem Sheets(Sht.Name).Cells(1, Cnt).Value
LastRow = Sheets(Sht.Name).Cells(Sheets(Sht.Name).Rows.Count, Cnt).End(xlUp).Row
Total = Total + LastRow - 2
End If
Next Cnt
Exit For
End If
Next Sht
frmEnlistment.txtTotalRecords.Value = Total
End Sub

Add this code...

Private Sub lboBattalion_Click()
Dim Sht As Worksheet, LastCol As Integer, Cnt As Integer, LastRow As Integer
For Each Sht In ThisWorkbook.Sheets
If frmEnlistment.lboRegiment.List(frmEnlistment.lboRegiment.ListIndex) = Sht.Name Then
With Sheets(Sht.Name)
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
For Cnt = 1 To LastCol
If Sheets(Sht.Name).Cells(1, Cnt).Value = _
        frmEnlistment.lboBattalion.List(frmEnlistment.lboBattalion.ListIndex) Then
LastRow = Sheets(Sht.Name).Cells(Sheets(Sht.Name).Rows.Count, Cnt).End(xlUp).Row
Exit For
End If
Next Cnt
Exit For
End If
Next Sht
frmEnlistment.txtTotalRecords.Value = LastRow - 2
End Sub

The end maybe? Dave

[HTSCF Fareha]

Dave, a H U G E thank you!!

Project complete!

As mentioned before, the other prefixes will not feature in this. People researching these will know if a specific Regiment has a prefix.

Many thanks,
Steve

[Dave]

That was quite a journey Steve. You are welcome. I hope that your initiative and these efforts will benefit the families of our past heroes. Be safe. Dave