使用数组变体从范围中复制和粘贴单元格

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

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

Answer 2

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