VBA Remove Columns and Strings in excel - excel

Question

I am working in a VBA Code that will remove unnecesary columns upon certain conditions
Dim keepColumn As Boolean
Dim currentColumn As Integer
Dim columnHeading As String
currentColumn = 1
While currentColumn <= ActiveSheet.UsedRange.Columns.Count
columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value
'CHECK WHETHER TO KEEP THE COLUMN
keepColumn = False
If columnHeading = "Agent" Then keepColumn = True
If columnHeading = "Interval" Then keepColumn = True
If columnHeading = "Break Time" Then keepColumn = True
If columnHeading = "Staffed Time" Then keepColumn = True
If columnHeading = "Lunch Time" Then keepColumn = True
If columnHeading = "Email Time" Then keepColumn = True
If columnHeading = "System Time" Then keepColumn = True
If columnHeading = "Personal Time" Then keepColumn = True
If keepColumn Then
'IF YES THEN SKIP TO THE NEXT COLUMN,
currentColumn = currentColumn + 1
Else
'IF NO DELETE THE COLUMN
ActiveSheet.Columns(currentColumn).Delete
End If
'LASTLY AN ESCAPE IN CASE THE SHEET HAS NO COLUMNS LEFT
If (ActiveSheet.UsedRange.Address = "$A$1") And (ActiveSheet.Range("$A$1").Text = "") Then Exit Sub
Wend
The second part of the codes requires to do 2 things, removes from column A, all characters but the letters, and also in column B changes 05/04/2021 00:00 -0600 - 05/05/2021 00:00 -0601 to just 05/04/21 (meaning, removes evrything after first space), this second part does take a while and I will like to make it faster. Any suggestions?
Function
`Function cleanString(str As String) As String
Dim ch, bytes() As Byte: bytes = str
For Each ch In bytes
If Chr(ch) Like "[A-Za-z]" Then cleanString = cleanString & Chr(ch)
Next ch
End Function`
And here is when i want to run it
Dim rng As Range
For Each rng In Sheets("Sheet2").Range("A1:A5000").Cells 'adjust sheetname and range accordingly
rng.Value = cleanString(rng.Value)
Next
Dim r As Range
For Each r In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Cells.SpecialCells(xlCellTypeConstants)
r.Value = Split(r.Value, " ")(0)
Next r
Finally I will like to run the code automatically when the info is updated

Answer 1

I will like to make it faster. Any suggestions?
Like I mentioned, read the range into an array and then perform the cleanup. It will be superfast!
LOGIC
Find last row in the relevant column
Store the range values in array
Perform the actions on the array rather than doing it directly on the range. For example extract alpha chars or getting part of a string. Remember to prefix the date part with ' to prevent Excel from auto formatting.
CODE
Here is an example. I have commented the code so if you get stuck then simply ask.
Option Explicit
Sub Sample()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim lRow As Long, i As Long
Dim MyAr As Variant
'~~> Change this to the relevant sheet which has data
Set wsInput = Sheet1
'~~> This is where the output will be dumped.
Set wsOutput = Sheet2
With wsInput
'~~> Find last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Store the range values in array
MyAr = .Range("A1:B" & lRow).Value2
'~~> perform the actions on the array
For i = LBound(MyAr) To UBound(MyAr)
'~~> Extract alpha chars
MyAr(i, 1) = GetAlphaChars(MyAr(i, 1))
'~~> Get the part before string. and prefix with ' to
'~~> prevent Excel from auto formatting
If InStr(1, MyAr(i, 2), " ") Then MyAr(i, 2) = "'" & Split(MyAr(i, 2), " ")(0)
Next i
End With
'~~> Send the output
wsOutput.Range("A1").Resize(UBound(MyAr), 2).Value = MyAr
End Sub
'~~> Function to extract Alpha characters from the string
Private Function GetAlphaChars(cellVal As Variant) As String
Dim regX As Object
Set regX = CreateObject("VBScript.Regexp")
With regX
.Pattern = "[^a-zA-Z]+"
.Global = True
GetAlphaChars = .Replace(cellVal, vbNullString)
End With
End Function
IN ACTION