How can I write the following lines of code in one line with an array?-CodePudding

I want to try to write the Range(K-AT) and PasteRange(1-6) as two single lines of code so as to shorten my code. How can I do this with an array?

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

CodePudding user response：

You don't need to copy the values

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
``

CodePudding user response：

Use a loop and do it dynamiclally:

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

Note that you need to paste until LastRow 1 if you copy from row 2 and paste from row 3 then LastRow needs to be 1 while pasting or you are missing the last row that you copied.

CodePudding user response：

Please, try the next code. It will return in sh2 worksheet. In my code example the next sheet. You may use what sheet you need:

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

Even a more compact version, using the same array, to accomplish the "single line with an array" :):

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