Predict Date of Enlistment

[HTSCF Fareha]

This is a project that I have been meaning to look at for a couple of years (since the 100th anniversary of the end of WW1 in 2018).
What I need this to do is two things:



Provide the ability to enter a service number and date of enlistment to add to the correct Regiment / Battalion combination. These details will be factual and obtained from surviving service records.
Provide a facility of obtaining the most accurate estimate of when a particular person may have enlisted, using their service number, based on the data that is already available.

Obviously, the result for obtaining 2) will provide a more accurate result with each entry that is input in 1).
Each time a new value is input into 1), then it should be added into the respective worksheet according to Regiment, Battalion, service number, then date of enlistment.

The top half of the UserForm handles the inputting of “new” data, whilst the bottom half deals with any enquiry. The bottom right box should indicate how accurate the predicted date is likely to be (Don't know if this is possible?).

I think that the Excel function that is likely to produce the most accurate estimated date of enlistment is ‘Forecast’.

My VBA / Excel knowledge is still in its infancy, so I am open to suggestions as to whether this is possible and what the most sensible way of achieving my goal might be. I have attached my initial thoughts and entered new worksheets for a few regiments, with accurate data for a couple. These will be added to in due course and should appear in the ComboBox in alphabetical (Regimental) order, then numerical (Battalion) order.
I realise that this might be a big ask, but just in case someone fancied a bit of a challenge.

Thanks!

[HTSCF Fareha]

Seasons greetings to all!

I've realised that I posted the wrong attachment.

[Dave]

Hi again HTCF. I don't understand your objective? U state "These details will be factual and obtained from surviving service records" but then U want to forecast their accuracy... it's 100%. I can't imagine that all the records are not surviving and so they would be available somewhere. I don't see any accuracy to forecast? Even if the records didn't survive, it seems to me that once they are provided by some valid source, then the accuracy would again be 100% with nothing to forecast. I fully support your effort to assist the heroes of the past but I just don't understand them. Dave

[SamT]

What is the algorithm for #2?

[HTSCF Fareha]

Hello Dave / Sam, alas the service records for WW1 were mostly destroyed by the Luftwaffe during WW2. The remaining ones that were saved from the fires are what are being used to populate the worksheets.

The forecasting of accuracy will come from known service numbers, then calculating a "likely" enrolment date from say looking at between the two dates either side that are factually known, or if there is a large gap providing a date along with a tolerance of say +/- so many days.

As more known service number / enrolment dates are entered, the theory being that the predicted dates will become more accurate. My hope is that expert's knowledge of Excel will be able to provide the most accurate method of producing a prediction.

I've been tinkering with the first part - populating the known service numbers / enrolment dates. Of course I'm struggling, but understand that the only way to learn is to try.


Option Explicit

Private Sub UserForm_Click()

Dim ShCount As Integer, i As Integer, j As Integer, ws As Worksheet

' Sort Regiment worksheets alphabetically
Application.ScreenUpdating = False

ShCount = Sheets.Count

For i = 1 To ShCount - 1
For j = i + 1 To ShCount
If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then
Sheets(j).Move before:=Sheets(i)
End If
Next j
Next i

' Populate Regiment
For Each ws In Worksheets
cboRegiment.AddItem ws.Name
Next ws

' Populate Battalion
Dim index As Integer
index = cboRegiment.ListIndex

cboBattalion.Clear

Application.ScreenUpdating = True

End Sub

Private Sub cmbEnter_Click()

' Input known soldier's number and enlistment date

Dim n As Variant, answer As String, ws As Worksheet
Set ws = Worksheets(ActiveSheet)

n = Application.InputBox("Please Enter Soldier Number", "Enlistment Database", "Enter Number Here", , , , 1)

answer = InputBox("Please enter known enlistment date in the following format: dd-mm-yyyy", "Enlistment Database", Format(Date, "dd/mmm/yyyy"))

If answer = "" Or n = "" Then
Exit Sub
Else

If n <> "" And IsNumeric(n) = True Then

answer = Format(answer, "DD/MM/YYYY")
' Validate date
If Not IsDate(answer) Or Not answer Like "[0-2]#/[01]#/[12][08]##" Then
If MsgBox("Invalid date or invalid date format" & _
"Please enter the date in the correct format", vbRetryCancel) = vbRetry Then
Exit Sub
Else
answer = Format(answer, "DD/MMM/YYYY")
Exit Sub
End If
End If

End If

' find the end of column A
Dim x As Integer
x = 1
Do Until ws.Range("A" & x).Value = ""
x = x + 1
Loop
' last row having data = x-1

' Add data to database
ws.Range("A" & x).Value = txtSoldierNumber.Value
ws.Range("B" & x).Value = txtEnlistmentDate.Value

' Clear text boxes
txtSoldierNumber.Value = ""
txtEnlistmentDate.Value = ""

End If
End Sub



I can forsee that this will only be of use for the 1st Battalion and providing I can get it to choose the right regiment!

[Dave]

Here's a start. Unfortunately I axed all of your code. HTH. Dave

[HTSCF Fareha]

Many thanks, Dave. Don't mind at all you axing the code if there is a more efficient way. Always looking to learn.

[HTSCF Fareha]

Sticking with the first part of trying to enter new Soldier numbers and Enlistments date.

[Dave]

Soldier entry is done... my apologies for axing your code again. I leave the rest to you. If U enter the soldier number enquiry, U need to find the sheet (regiment), then the battalion and then search for the soldier number to see if it exists. If it does, show the date of enlistment. If it doesn't show the dates of the enlistment number before the soldier number and the date of the enlistment number after the soldier number. There is no accuracy prediction. HTH. Dave

[HTSCF Fareha]

Dave, absolutely no need to apologise for axing my code. My appreciation goes to you for progressing the project!

The only thing that I would make comment on, is that the date is input as text, so it produces the dreaded left aligned text field which will not format to a date when trying to change the properties of the cell / column.

I'm going to have a bit of a dig around to see if this can be rectified at code source.

It looks like CDate will be the answer.

Thanks again!

[HTSCF Fareha]

Scratch the last! It was me using an existing table for data.
Although there is something strange happening.....



2580
12/01/1888


3085
01/03/1889


3462
14/01/1890


3753
20/01/1891


4034
20/03/1892


4663
26/09/1893


5015
01/09/1894


5249
28/01/1895


5671
23/04/1896


6044
10/08/1897


6312
20/07/1898


6571
24/07/1899


6747
03/01/1900


6928
26/02/1901


7233
07/08/1902


7413
19/01/1903


7947
02/05/1904

[Dave]

HTSCF it doesn't matter what it looks like when it's stored in the worksheet. You will be displaying the date on the userform. As far as I could tell, the sheet itself or the sample data that U had included was oddly formatted. If U blank all the data from the worksheets(regiments) and re-enter the soldier info, then all the date data on the worksheet(s) would be the same... not that it matters. Dave

[HTSCF Fareha]

My thanks to Dave for getting things this far.

The next part is what I was really hoping to achieve - a means of predicting an enlistment date based on known dates.

My initial thought was to perhaps use the Forecast function. Do we think this might be the way forward?

[Dave]

HTSCF please review #9... I've already given U a path forward. The soldier number if unknown, will be enlisted somewhere between the date of the soldier number before and the date of the soldier number after. Dave

[HTSCF Fareha]

I hadn't forgotten the advice in post #9 Dave, I was just posing the question as to whether there was perhaps another way to provide a more mathmatical (accurate) means of obtaining an enlistment date.

Take the following selection:-



Soldier Number
Confirmed Date of Enlistment


13
06/09/1881


196
13/01/1882


617
05/01/1883



1491
18/09/1884





If one was to enquire when say soldier 15 enlisted for example, logic would suggest a date much nearer to #13 than to #196. Whereas your suggested method, if I am understanding correctly, will provide a date of 06/09/1881 + 64.5 days, giving a date of 10/11/1881 (when rounded up).

Adding a few more known numbers / dates for the same Regiment, one arrives at the following:-

13 06/09/1881
59 16/10/1881
62 16/10/1881
64 17/10/1881
72 21/10/1881
110 11/11/1881
196 13/01/1882

So the method of date prediction will need to be able to calculate and allow for multiple enlistments on the same day.

[HTSCF Fareha]

I'm getting some bizarre results when inputting dates after 1900. All dates so far entered from 1881 to 1899 were all entered correctly (UK date format dd/mm/yyyy). Entering anything over 01/01/1900 (1st January 1900) switches the date and month about.

Does anyone know why this happens and how this might be overcome?

[HTSCF Fareha]

Forgot to show the code re the last post.


For Each Sht In ThisWorkbook.Sheets
If frmEnlistment.ListBox1.List(frmEnlistment.ListBox1.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.ListBox2.List(frmEnlistment.ListBox2.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 = Format(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), "dd/mm/yyyy")
Exit Sub
End If
Next Cnt2
.Cells(LastRow + 1, Cnt) = frmEnlistment.txtSoldierNumber.Value
.Cells(LastRow + 1, Cnt + 1) = Format(frmEnlistment.txtEnlistmentDate.Value, "dd/mm/yyyy")
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

[Dave]

HTSCF The rate of enlistment is unknown and likely inconsistent making the validity of projections uncertain... seems like a lot of work to produce erroneous results. You could look at the rate of enrollment over time for some period before the soldier in question and the rate of enrollment for some period after the soldier in question and then try to average these rates to "project" the actual date of enrollment... again I'm uncertain if there's any value to doing this. Dave
Vba converting date string to 1900 date (microsoft.com) (https://social.msdn.microsoft.com/Forums/office/en-US/068227c7-3dcb-4c72-ad1e-5e83917a2524/vba-converting-date-string-to-1900-date)
Differences between the 1900 and the 1904 date system - Office | Microsoft Docs (https://docs.microsoft.com/en-us/office/troubleshoot/excel/1900-and-1904-date-system)

[HTSCF Fareha]

I think that you're right, Dave. Now I've been entering dates, there are all sorts of permetations that I'm coming across.

My thinking is to let the user enter a service number, then have the VBA form show five enlistment dates / service numbers that are known either side of the query, thus allowing the user to make their own reasoned guestimate as to the actual date of enlistment.

I'm now going to have a read of the two links to see if there is a way around the date issue.

Thanks again for your feedback!

[HTSCF Fareha]

This seems to work for dates after 01/01/1900, after reading the suggestions in the first link, but obviously fails for earlier dates.


Option Explicit
Sub DateTest()
Dim Sht As Worksheet, r As Variant
Dim rangeAll As Excel.Range
Set Sht = ActiveWorkbook.Worksheets("Sheet1")
Set rangeAll = Sht.Range("A1:A20")
Dim formulaString As String
For Each r In rangeAll
formulaString = "=Text(""" & r.Value & """,""DD/MM/YYYY"")"
r.Value = formulaString
Next r
End Sub

How would one incorprate it into the existing code? Would it need an "else if" scenario to read the differences in the input for dates > 31/12/1899 using the exisiting code, then another section for dates < 01/01/1900

[Dave]

HTSCF allowing users to make an informed guestimate of their own, as U outlined, seems like it would provide the end user with the most benefit. You can trial this to fix your date format concerns. HTH. Dave

If Right(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), 4) <= 1900 Then
frmEnlistment.txtEnlistmentDate.Text = Format(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), "dd/mm/yyyy")
Else
frmEnlistment.txtEnlistmentDate.Text = CStr(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1))
End If

[HTSCF Fareha]

Nice one, thanks Dave!

I'm really surprised that Microsoft hasn't fixed what I am sure is a very common issue for VBA programmers.

[HTSCF Fareha]

Okay, I've thought out how I want to search / display the results of the query, but my VBA knowledge (and G**gle) has let me down.


Private Sub cmbEnquiry_Click()

Dim LastRow As Integer, LastCol As Integer, Cnt As Integer, Cnt2 As Integer
Dim Sht As Worksheet, SortRange As Range

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

If frmEnlistment.ListBox1.ListIndex = -1 Then
MsgBox "Select Regiment!", vbExclamation + vbOKOnly, "Soldier Enlistment"
Exit Sub
End If
If frmEnlistment.ListBox2.ListIndex = -1 Then
MsgBox "Select Battalion!", vbExclamation + vbOKOnly, "Soldier Enlistment"
Exit Sub
End If
If frmEnlistment.txtSoldierNumberEnq = vbNullString Then
MsgBox "Input Soldier Number to Query!", vbExclamation + vbOKOnly, "Soldier Enlistment"
Exit Sub
End If

For Each Sht In ThisWorkbook.Sheets
If frmEnlistment.ListBox1.List(frmEnlistment.ListBox1.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.ListBox2.List(frmEnlistment.ListBox2.ListIndex) Then
LastRow = .Cells(.Rows.Count, Cnt).End(xlUp).Row
For Cnt2 = 3 To LastRow





Exit For
End If
Next Cnt
Exit For
End With
End If
Next Sht

frmEnlistment.txtSoldierNumberEnq.Text = vbNullString
frmEnlistment.txtEstEnlistmentDateResult.Text = vbNullString
frmEnlistment.ListBox1.ListIndex = -1
frmEnlistment.ListBox2.ListIndex = -1
End Sub

[HTSCF Fareha]

Still plodding my way through.

The enlistment date enquiry function needs to enable the user to select Regiment and Battalion and a Soldier Number to enquire about.

If the Soldier number exists, then the result of the Soldier Number and Enlistment Date need to be displayed in txtEstEnlistmentDateResult with a short message indicating that this is the case.

If the Soldier Number doesn't exist, then the txtEstEnlistmentDateResult box should show five enlistment numbers and their respective enlistment dates either side of the entered Soldier Number. Again, ideally with a message to explain that an exact Soldier Number / Enlistment Date combination was not found.


Private Sub cmbEnquiry_Click()

Dim LastRow As Integer, LastCol As Integer, Cnt As Integer, Cnt2 As Integer
Dim Sht As Worksheet, SortRange As Range, Solnumberdate As Variant

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

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.txtSoldierNumberEnq.Value) Or _
frmEnlistment.txtSoldierNumberEnq.Text = vbNullString Then
MsgBox "Input Soldier Number to Query!", 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
frmEnlistment.txtEnlistmentDate.Text = vbNullString
' Display existing Soldier Number and Enlistment Date in txtEstEnlistmentDateResult

frmEnlistment.txtSoldierNumberEnq.txtEstEnlistmentDateResult


Exit Sub
End If
Next Cnt2

Exit For
End If
Next Cnt
Exit For
End With
End If
Next Sht

frmEnlistment.txtSoldierNumberEnq.Text = vbNullString
frmEnlistment.txtEstEnlistmentDateResult.Text = vbNullString
frmEnlistment.lboRegiment.ListIndex = -1
frmEnlistment.lboBattalion.ListIndex = -1
End Sub

I was wondering if the Offset or Resize method would help with selecting a range of five Soldier Number / Enlistment Dates?

Really struggling to sort this so help would be very much appreciated! I keep looking and trying things without any sucess. Leave it for a while and research / enter a few more known Soldier Numbers / Enlistment Dates, then go back to it again.

[Dave]

HTSCF I don't understand why U want the user to select Regiment and Battalion and then enter a Soldier Number to enquire about? Is the regiment and battalion always known? Why not just enter the soldier number and then report the regiment and battalion if known? I've been unable to resolve the 1900 date problem... when the date is retrieved, even though entered as for example 04-01-1900 (d-m-y), the 1900 dates are 1 day off when returned ie. 03-01-1900 is returned re. the leap year. This code is better than last, but still needs to be adjusted to accommodate the leap year.

If Left(CDate(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1)), 4) <> 1900 ThenfrmEnlistment.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
Dave

[HTSCF Fareha]

Dave, thanks for your reply.

I see why you're asking about whether the Regiment and Battalion are known, but most people who are researching someone will "usually" know what Regiment someone was in and more often or not the Battalion too. The idea was to provide an idea of when someone might've enlisted, which is usually because so many records were destroyed in the Blitz, meaing that this detail was missing. Regiments and Battalions can be found on other types of war records, but not Enlistment Dates.

I was thinking that it would become too complicated if just a soldier number were entered, which might potentially give a number of permutations across Regiments / Battalions.

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. I haven't tried entering any of these yet as the Hampshire Regiment uses standard numbers. But looking at the code I see that the Soldier Number input is checking for a numeral.

I'm not understanding how the date issue fits in when trying to read and retrieve from existing data. Mind you it wouldn't be the first time I've missed something obvious. The date entry seems to be working fine at the moment and is allowing entry of dates prior to and after 1900 without issue so far. Or are you trying to allow for someone who might've enlisted on February 29th? The form will only be used to find an Enlistment Date from the Soldier Number and not the other way around.

I've altered the form and code to use camelback to try and adhere to best VBA principles as per #24.

Thanks again!

[Dave]

"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".... argh!!! I'm at a loss as to how you would standardize any process to predict enrollment dates if the soldiers aren't simply sequentially numbered? As for the date, entry doesn't seem to be the problem. As stated, "when the date is retrieved, even though entered as for example 04-01-1900 (d-m-y), the 1900 dates are 1 day off when returned ie. 03-01-1900 is returned" The indented code is great except it doesn't usually post well. Here's the code for your "Enquiry" button... it doesn't do the 5 before and after thing but it is a start. I think the prefix thing will make the whole thing moot anyways. Dave

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


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


If frmEnlistment.ListBox1.ListIndex = -1 Then
MsgBox "Select Regiment!", vbExclamation + vbOKOnly, "Soldier Enlistment"
Exit Sub
End If
If frmEnlistment.ListBox2.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


For Each Sht In ThisWorkbook.Sheets
If frmEnlistment.ListBox1.List(frmEnlistment.ListBox1.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.ListBox2.List(frmEnlistment.ListBox2.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
End If
Next Cnt2
If Not Flag Then
frmEnlistment.txtEstEnlistmentDateResult.Text = "Soldier not Enlisted!"
End If
Exit For
End If
Next Cnt
End With
End If
Next Sht
End Sub

[HTSCF Fareha]

This is great Dave, thanks!

I didn't mean to try and throw a curved ball in and should've explained just a little better. Some Regiments did use letter prefixes, but this was standard for the whole battalion, so anyone searching one of those would already know to put the prefix in front of any soldier number that was located. So the number system is just fine.

[HTSCF Fareha]

I think I've read somewhere that using 'select' is a bad thing, but for trying to select five Soldier Numbers / Enlistment dates either side of a Soldier Number query, I was wondering if something along the lines of this might work? I've picked C10 out of randomness.


Range(Range("C10").Offset(-5, 0), Range("C10").Offset(5, 0)).Select

[HTSCF Fareha]

I'm getting a date problem when the user inputs 03/01/1900 (d/m/y), as the entry goes in as 01/03/1900. If you "cheat" and put the date as 01/03/1900 to get the desired result of 03/01/1900, it goes in okay. :confused:


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

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

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 = Format(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), "dd/mm/yyyy")
Exit Sub
End If
Next Cnt2
.Cells(LastRow + 1, Cnt) = frmEnlistment.txtSoldierNumber.Value
.Cells(LastRow + 1, Cnt + 1) = Format(frmEnlistment.txtEnlistmentDate.Value, "dd/mm/yyyy")

' Sort out 1900 date issue
If Left(CDate(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1)), 4) <> 1900 Then
frmEnlistment.txtEnlistmentDate.Text = Format(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), "dd/mm/yyyy")
Else
frmEnlistment.txtEnlistmentDate.Text = CStr(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1))
End If
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

Or is this because of the leap year issue? Entering 23/01/1900 (d/m/y) goes in correctly.
Then 03/02/1900 (d/m/y) inputs as 02/03/1900, with 13/02/1900 (d/m/y) correctly again.

It appears that every date in 1900 that has a day that could also be a month i.e. from the 1st through to the 12th, then these are entered back to front. Any date after 12th is entered correctly.

[Dave]

HTSCF I see your still at this. I don't have any idea why the date thing can't be resolved... I tried and failed.
Here's 4 soldiers either side of an unknown.... 5 soldiers made for poor presentation. I'm guessing once you add the prefixes, quite a bit of code change will be required. Dave

[HTSCF Fareha]

Many thanks, Dave. Not a post that I was expecting, but extremely well received!

The date thing is really strange. I'm going to keep searching to see if there is an explanation / solution.

The soldier number bit works great!! I really appreciate you taking the time to stick with it and coming up with a solution.

I've attached the file along with a few "cosmetic" changes and further enlistment date updates!

Steve

[Dave]

You are welcome Steve. Here's some more cosmetic changes and a functional change re. clearing listboxes when using the Enquiry. Hope U will like them. Dave

[HTSCF Fareha]

Woah, the colours certainly pop! Possibly a bit too much for my eyes. :)

I'll take a closer look at the code tomorrow. Thanks!

[HTSCF Fareha]

I like the clearing of the enlistment date predictions - much neater!

I was wondering if there would be a way of adding another 'If Else' statement to the date format function, so that any dates after 1900, that also have a day of 1 to 12, might switch the dd and mm about?


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

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

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 = Format(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), "dd/mm/yyyy")
Exit Sub
End If
Next Cnt2
.Cells(LastRow + 1, Cnt) = frmEnlistment.txtSoldierNumber.Value
.Cells(LastRow + 1, Cnt + 1) = Format(frmEnlistment.txtEnlistmentDate.Value, "dd/mm/yyyy")

' Sort out 1900 date issue
If Left(CDate(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1)), 4) <> 1900 Then
frmEnlistment.txtEnlistmentDate.Text = Format(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1), "dd/mm/yyyy")
Else
frmEnlistment.txtEnlistmentDate.Text = CStr(Sheets(Sht.Name).Cells(Cnt2, Cnt + 1))
End If
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

[Dave]

Steve, again, I don't have any idea why the date thing can't be resolved... I tried and failed. You have a UK OS and I have a Canadian OS so I don't seem to be able to enter dates like your data ie. with slashes. Not that it matters re. the 1900 date problem. Here's am interesting read and possible solution. Perhaps starting a new thread about the whole issue would be warranted. Dave
How to Work with Dates Before 1900 in Excel - ExcelUser.com (https://exceluser.com/1057/how-to-work-with-dates-before-1900-in-excel/#:~:text=In%20Excel,%20dates%20are%20numbers,%20called%20date%20serial,1%20 represents%20one%20day%20earlier:%20December%2031,%201899.)

[HTSCF Fareha]

Snap! I saw that too when trying to find a solution. I've also read that the leap year issue is so that users changing from Lotus 123 to Microsoft Excel can migrate their data. Down to the fact that the "error" was with Lotus who were trying to make their product fit in a smaller memory size. Annoyingly, this doesn't help the majority of us Excel users!

I'll do a dig around this forum before raising the issue. Definitely a good idea!

One last thing before I close this thread off - is there a small piece of code that could fit into that shown in post #34 (after the final 'End With'?) that could do a count of all the records using the 'Regiment' and 'Battalion' combination, providing the result in a textbox called 'txtTotalRecords' after the 'cmbEnter' button is pressed?

Thanks again Dave!

Steve

[Dave]

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

[Paul_Hossler]

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


Agree - not sure why this is a separate thread?????

http://www.vbaexpress.com/forum/showthread.php?68356-Date-Entry-Not-Being-Correctly-Interpreted

I've only been looking at the Date part

However, the interpolation (if that's what's going on) to guess an enlistment date based on the input and two surrounding soldier numbers would have to be done using the VBA dates

[Paul_Hossler]

Thought occurs

Instead of trying to do 3 functions on one user form, IMHO it'd be easier to maintain and more user friendly to have 3 user forms, each only doing a single function

27870

[HTSCF Fareha]

Many thanks Dave, this seems to work just fine! :thumb

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

27871


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

27871


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.:bow:

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! :banghead:


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!! :clap:

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