you can use Array() of worksheet names and Array() of columns to process multiple sheets:
Private Sub RMS_UpdateDateColumn()
Dim arrWsh As Variant
Dim arrCol As Variant
Dim i As Integer
' the worksheets to work with, Change the name if necessary
arrWsh = Array("Involved", "Sheet2")
' the column number where the date is located, change the column Number if necessary
arrCol = Array(4, 4)
For i = 0 To UBound(arrWsh)
Call RMS_History(Worksheets(arrWsh(i)), arrCol(i))
Next
End Sub
Private Sub RMS_History(ByRef ws As Worksheet, ByVal nCol As Long)
Dim x As Variant
Dim rw As Long, last_rw As Long
Dim vlue As Variant
Dim txt As String
Dim dte As Variant, tim As String
Application.ScreenUpdating = False
' -------------------------------------------------------
' Set font for each worksheet
With ws
.Cells.Font.Name = "Calibri"
.Cells.Font.Size = 11
.Cells.VerticalAlignment = xlVAlignCenter
.Cells.HorizontalAlignment = xlHAlignLeft
' -------------------------------------------------------
' Perform the basic editing
' Tidy date column by converting from text to required date format
last_rw = .Cells(.Cells.Rows.Count, nCol).End(xlUp).Row
For rw = 2 To last_rw
vlue = .Cells(rw, nCol)
txt = WorksheetFunction.Text(.Cells(rw, nCol), "m")
If IsNumeric(txt) Then
'if numeric, it is a valid date
.Cells(rw, nCol) = CDate(Month(vlue) & "/" & Day(vlue) & "/" & Year(vlue)) + TimeValue(vlue)
Else
'not valid date
dte = Split(vlue, "/")
tim = Split(dte(2))(1)
dte(2) = Replace$(dte(2), tim, "")
.Cells(rw, nCol) = CDate(dte(1) & "/" & dte(0) & "/" & dte(2)) + TimeValue(tim)
End If
.Cells(rw, nCol).NumberFormat = "dd/mm/yyyy"
Next
.Columns("E:E").Delete ' Delete column E as this is not required
' Delete all rows with a date older than eighteen months
.AutoFilterMode = False
Dim FilterRange As Range, myDate As Date, myCol As String
myCol = ColumnLetter(nCol)
myDate = DateSerial(Year(Date) - 1, Month(Date) - 6, Day(Date))
Set FilterRange = .Range(myCol & "2:" & myCol & .Cells(.Rows.Count, 1).End(xlUp).Row)
FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)
On Error Resume Next
With FilterRange
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
End With
Err.Clear
Set FilterRange = Nothing
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
' chatgpt
Function ColumnLetter(ByVal ColNum As Integer) As String
Dim vArr As Variant
vArr = Split(Cells(1, ColNum).Address(True, False), "$")
ColumnLetter = vArr(0)
End Function