Use an array variant to copy and paste cells from a range

Question

I have used an array to complete some of my project but couldn't get it to work on copying a range of cells and pasting them. I had to revert to a Instr command instead on all the variants. It works but is very clunky and resource hungry. If someone could provide a better solution using the array It would certainly make the project more efficient. My code to date is:

Option Explicit

Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean

Sub TimeKeeper()

Dim MyCell As Range
Dim lr As Integer
Dim DeleteStr As String
Dim i As Integer
Dim V As Variant, TimeKeepers As Variant

'Create Array called Timekeepers and populate with Staff Initials
TimeKeepers = Array("AP", "AV", "DHS", "EJM", "EM", "EZM", "GR", "IMP", "JDC", "JLC", "JS", "JY", "LE", "RD", "RR", "RSM", "SJR", "SK", "TC")

'Optimize Code
Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

'Ensure columns fit across Worksheet
Cells.EntireColumn.AutoFit

'Cut Cells in Row 6 from Column "C" to "H" and Paste at "G5"
Range("C6:H6").Cut Destination:=Range("G5")
Application.CutCopyMode = False

'Insert New Column before Column "G"
Range("G:G").EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove

'Populate new Column with Heading
Range("G5").Value = "Timekeeper"

'Declare String Variable
DeleteStr = "Bill Subtotal:"
'With each instance of "Bill Subtotal:" delete row
lr = Cells(Rows.Count, 2).End(xlUp).Row
    For i = lr To 1 Step -1
        If Cells(i, 2) = DeleteStr Then Rows(i & ":" & i).EntireRow.Delete
    Next i

'For each change in staff initials copy account data from "B" Column to "H" Column and Paste to `Column "G" against those intitials
For Each MyCell In Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    If InStr(MyCell.Text, "AP") Or InStr(MyCell.Text, "AV") Or InStr(MyCell.Text, "DHS") Or _
    InStr(MyCell.Text, "EJM") Or InStr(MyCell.Text, "EM") Or InStr(MyCell.Text, "EZM") Or _
    InStr(MyCell.Text, "GR") Or InStr(MyCell.Text, "IMP") Or InStr(MyCell.Text, "JDC") Or _
    InStr(MyCell.Text, "JLC") Or InStr(MyCell.Text, "JS") Or InStr(MyCell.Text, "JY") Or _
    InStr(MyCell.Text, "LE") Or InStr(MyCell.Text, "RD") Or InStr(MyCell.Text, "RR") Or _
    InStr(MyCell.Text, "RSM") Or InStr(MyCell.Text, "SJR") Or InStr(MyCell.Text, "SK") Or InStr(MyCell.Text, "TC") _
    Then
       MyCell.Resize(, 7).Copy
       MyCell.Offset(-1, 5).PasteSpecial xlPasteValues
    End If
Next MyCell

Application.CutCopyMode = False

'For each Variant delete the row
For Each V In TimeKeepers
    Columns("B").Replace "*" & V & "*", "#N/A", xlWhole, , True, False, False
Next
On Error Resume Next
    Columns("B").SpecialCells(xlConstants, xlErrors).EntireRow.Delete
On Error GoTo 0e

Answer 1

If you are matching multiple values in a string then a Regular Expression is a useful tool. Create a pattern from the array with Join(array,"|") to get a string like "AP|AV|DHS|EJM etc" (assuming they are all alphabetic A to Z). Then use regex.test(string) in your If block.

    TimeKeepers = Array("AP", "AV", "DHS", "EJM", "EM", "EZM", _
                    "GR", "IMP", "JDC", "JLC", "JS", "JY", _
                    "LE", "RD", "RR", "RSM", "SJR", "SK", "TC")

    ' build regular expression pattern to match any initials
    Dim Re As Object, sPattern As String
    Set Re = CreateObject("vbscript.regexp")
   
    sPattern = Join(TimeKeepers, "|")
    With Re
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = sPattern
    End With

    For Each MyCell In Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        If Re.test(MyCell.Value) Then
           MyCell.Resize(, 7).Copy
           MyCell.Offset(-1, 5).PasteSpecial xlPasteValues
           'MyCell = "#N/A" ' why not do this now instead of later
        End If
    Next MyCell