如何在一行中用数组编写以下代码行？

Question

我想尝试将 Range(K-AT) 和 PasteRange(1-6) 写成两行代码，以缩短我的代码。如何使用数组做到这一点？

Set RangeK = .Range("K2", "K" & LastRow)
Set RangeD = .Range("D2", "D" & LastRow)
Set RangeW = .Range("W2", "W" & LastRow)
Set RangeX = .Range("X2", "X" & LastRow)
Set RangeZ = .Range("Z2", "Z" & LastRow)
Set RangeAT = .Range("AT2", "AT" & LastRow)

Set PasteRange1 = .Range("A3", "A" & LastRow)
Set PasteRange2 = .Range("B3", "B" & LastRow)
Set PasteRange3 = .Range("C3", "C" & LastRow)
Set PasteRange4 = .Range("D3", "D" & LastRow)
Set PasteRange5 = .Range("E3", "E" & LastRow)
Set PasteRange6 = .Range("F3", "F" & LastRow)

RangeK.Copy
PasteRange1.PasteSpecial xlPasteValues

RangeD.Copy
PasteRange2.PasteSpecial xlPasteValues

RangeW.Copy
PasteRange3.PasteSpecial xlPasteValues

RangeX.Copy
PasteRange4.PasteSpecial xlPasteValues

RangeZ.Copy
PasteRange5.PasteSpecial xlPasteValues

RangeAT.Copy
PasteRange6.PasteSpecial xlPasteValues

Answer 1

使用循环并动态执行：

Option Explicit

Public Sub CopyExample()
    
    Dim ColumnsToCopy As Variant  ' define your columns to copy
    ColumnsToCopy = Array("K", "D", "W", "X", "Z", "AT")
    
    Dim iCol As Long  ' for each of that columns …
    For iCol = LBound(ColumnsToCopy) To UBound(ColumnsToCopy)
        
        ' copy column
        Worksheets("source").Range(ColumnsToCopy(iCol) & "2", ColumnsToCopy(iCol) & LastRow).Copy
        
        ' paste column
        With Worksheets("destination")
            .Range(.Cells(3, iCol + 1), .Cells(LastRow + 1, iCol + 1)).PasteSpecial xlPasteValues
        End With
    Next iCol

End Sub

请注意，如果您从第 2 行复制并从第 3 行粘贴，则需要粘贴到 LastRow + 1，然后在粘贴时 LastRow 需要为 +1，否则您会丢失复制的最后一行。

Answer 2

您不需要复制值

Option Explicit

Private Const startRowSource As Long = 2
Private Const startRowTarget As Long = 3

Sub copyRanges()


Dim wsSource As Worksheet, wsTarget As Worksheet
Dim LastRow As Long

'set wsSource and wsTarget and lastRow here
'....


Dim arrRanges(5, 1) As Range    'mapping via two-dimensional array: first = source, second = target

With ws
    Set arrRanges(0, 0) = "K": Set arrRanges(0, 1) = "A"

    '... add missing mappings
    
    Set arrRanges(5, 0) = "AT": Set arrRanges(5, 1) = "F"
End With

Dim i As Long, rgSource As Range, rgTarget As Range

For i = 0 To UBound(arrRanges, 1)
    Set rgSource = wsSource.Range(arrRanges(i, 0) & startRowSource, arrRanges(i, 0) & LastRow)
    Set rgTarget = wsTarget.Range(arrRanges(i, 1) & startRowTarget, arrRanges(i, 1) & LastRow)
    rgSource.Value = rgTarget.Value
Next

End Sub
``

Answer 3

请尝试下一个代码。它将在sh2 工作表中返回。在我的代码示例中，下一张表。您可以使用您需要的表格：

Sub testPasteDiscRArrays()
 Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, arr, arrFin

 Set sh = ActiveSheet  'use here the necessary sheet to copy from
 Set sh1 = sh.Next     'use here the necessary sheet to paste
 lastR = sh.Range("D" & sh.rows.count).End(xlUp).row 'use the correct reference column
 arr = sh.Range("D2:AT" & lastR).Value 'place all involved range in an array
 'slice the array by necessary columns (n#) in the whished order:
 arrFin = Application.Index(arr, Evaluate("row(1:" & UBound(arr) & ")"), Array(8, 1, 20, 23, 43))
 'drop the processed array content, at once:
 sh1.Range("A3").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).Value = arrFin
End Sub

甚至更紧凑的版本，使用相同的数组，来完成“单行数组”:)：

Sub testPasteDiscRArrays()
 Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, arr

 Set sh = ActiveSheet
 Set sh1 = sh.Next
 lastR = sh.Range("D" & sh.rows.count).End(xlUp).row
 arr = sh.Range("D2:AT" & lastR).Value

sh1.Range("A3").Resize(UBound(arr), 5).Value = _
      Application.Index(arr, Evaluate("row(1:" & UBound(arr) & ")"), Array(8, 1, 20, 23, 43))
End Sub