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

Question

我已经使用数组来完成我的一些项目，但无法使用它来复制和粘贴一系列单元格。我不得不在所有变体上恢复为 Instr 命令。它有效，但非常笨重并且资源很饿。如果有人可以使用数组提供更好的解决方案，那肯定会使项目更有效率。我的代码是：

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

这不是开始发现数组最简单的难题，但尽管开始时学习曲线很艰难，但一旦掌握了它，您将永远不会回头:)。

下面是第一个结构，希望能帮助您快速入门，如果您遇到困难，请继续post您在该主题中的问题：

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

如果您要匹配一个字符串中的多个值，那么 Regular Expression 是一个有用的工具。使用 Join(array,"|") 从数组中创建一个模式，以获取类似 "AP|AV|DHS|EJM etc" 的字符串（假设它们都是字母 A 到 Z）。然后在 If 块中使用 regex.test(string)。

    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

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

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

arrays

excel

vba

copy-paste