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

I'm not sure of your exact requirements, but if you just care about cell values, assinging values directly is much faster than copy/paste: destinationCell.Value = sourceCell.Value. Works with ranges too if you ensure they are of the same dimensions. — SnowGroomer, May 17 '21 at 09:13

score 0 · Answer 1 · answered May 17 '21 at 11:08

not the easiest puzzle to start discovering arrays but although the learning curve is heavy in the beginning, once you get a grip of it you'll never go back :).

Hereunder a first structure that hopefully will get you a kickstart, if you get stuck just continue to post your questions in this thread:

Sub test()

    'Set some vars
    Dim arr, arr2, collCorr As Long
    arr = Sheet1.Range("A1").CurrentRegion.Value2 'get all data in memory
    collCorr = 1 'the number of col's you want to add
    arr2 = arr 'get all data in target array
    ReDim Preserve arr2(1 To UBound(arr), 1 To UBound(arr, 2) + collCorr) 'Resize the new array including the column inserts
    
    'build new array
    Dim i As Long, j As Long, jj As Long: jj = 1
    Dim ii As Long: ii = 1
    For j = 1 To UBound(arr) 'traverse rows
        For i = 1 To UBound(arr, 2) 'traverse cols
            'do all tranformations here, keep in mind that adding columns will offset your data e.g col G becomes H etc.
            'If xxx Then
            'ElseIf xx Then
            
            'e.g. Cut Cells in Row 6 from Column "C" to "H" and Paste at "G5"
            If j = 6 And i >= 3 And i <= 8 Then 'if C6 to H6
                arr2(j, i) = "" 'emty cell = cut
                arr2(j - 1, i + 6) = arr(j, i) 'paste G5
            End If
        Next i
    Next j
    
    'dumb new array to sheet
    With Sheet2
        .Range(.Cells(1, 1), .Cells(UBound(arr2), UBound(arr2, 2))).Value2 = arr2
    End With
End Sub

Although I have used @CPD1802 code as an answer I believe your example would also something for me to explore. Again, there is much I need to learn about arrays. — Martin Hewitt Tayler, May 18 '21 at 18:46

score 0 · Accepted Answer · answered May 17 '21 at 17:15

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

I had not thought of pattern matching before using `Regex`. In fact, I probably haven't explored this in any of the coding I've done in the past. Your solution works and is a little quicker than the `Instr` function so I will use it for the project. The link you provided is useful so it looks like I have much reading to do. — Martin Hewitt Tayler, May 18 '21 at 18:44

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

2 Answers2