copy from sheet1 cols A,B,C,G,F,R,S,T to sheet 2 in colums A,B,C,D,E,F,G,H

Question

Excel macro 2016 in VBA. Need to copy from 8 separated columns from one sheet to another, in different order. Tried but the Paste is done always in same column A...

Code starts with:

Sub Button1_Click()

Dim ultima_fila As Long
Dim rango, columna As String

Sheets("Validation by rules").Select
ultima_fila = Cells(Rows.Count, 1).End(xlUp).Row

' TableName
columna = "A"
    rango = columna & "1:" & columna & CStr(ultima_fila)
    MsgBox rango
    range(rango).Copy
    Sheets("TMP").Paste

'TableField
columna = "B"
    rango = columna & "1:" & columna & CStr(ultima_fila)
    MsgBox rango
    range(rango).Copy
    Sheets("TMP").Paste

However, I don't know how to tell the macro to paste the second time into B...? or any other btw...

Also, tried a For loop with no success to avoid copy/paste my code... something like:

For X in (A,B,C,F,G,R,S,T)

No luck either...

Thanks a lot!

Answer 1

You are not telling the code where to paste with: Sheets("TMP").Paste. You only name the sheet but not the column.

Also use a loop so you do not need to keep retyping the same thing:

Sub Button1_Click()

Dim ultima_fila As Long
Dim columnOrd As Variant
columnOrd = Array("A", "B", "C", "G", "F", "R", "S", "T")

With Sheets("Validation by rules")
    ultima_fila = .Cells(.Rows.Count, 1).End(xlUp).Row

    Dim i As Long
    For i = 1 To 8
        MsgBox .Range(.Cells(1, columnord(i - 1)), .Cells(ultima_fila, columnord(i - 1))).Address
        .Range(.Cells(1, columnord(i - 1)), .Cells(ultima_fila, columnord(i - 1))).Copy Destination:=Sheets("TMP").Cells(1, i)
    Next i
End With

End Sub

Answer 2

Use an array to collect, reshape then return the values.

A,B,C,G,F,R,S,T to sheet TMP in columns A,B,C,D,E,F,G,H

Sub Button1_Click()

    Dim i As Long, arr as variant

    with workSheets("Validation by rules")

        'collect
        i= .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .range(.cells(1,"A"), .cells(i, "T")).value

        'reshape part 1
        for i=lbound(arr, 1) to ubound(arr, 1)
            arr(i, 4) = arr(i, 7)
            arr(i, 5) = arr(i, 6)
            arr(i, 6) = arr(i, 18)
            arr(i, 7) = arr(i, 19)
            arr(i, 8) = arr(i, 20)
        next i

    end with

    'reshape part 2
    redim preserve arr(lbound(arr, 1) to ubound(arr, 1), lbound(arr, 2) to 8)

    'return
    workSheets("TMP").cells(1,1).resize(ubound(arr, 1), ubound(arr, 2)) = arr

end sub

Answer 3

If:

1. Your data is stored in a file on disk (and not in-memory in an open Excel workbook with unsaved changes), and
2. You only want to copy and paste the data, not formatting

then you can read the relevant columns in the appropriate order into an ADODB Recordset, and then copy the recordset data into the destination using the CopyFromRecordset method.

Add a reference to Microsoft ActiveX Data Objects 6.1 Library (via Tools -> References...). There may be versions other than 6.1; choose the highest.

Then, you can use the following code:

Dim excelPath As String
excelPath = "C:\path\to\excel\file.xlsx" ' Replace with the path to the Excel file

Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & excelPath & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No"""            

Dim sql As String
sql = _
    "SELECT F1, F2, F3, F4, F6, F18, F19, F20 " & _
    "FROM [Validation by rules$] "
' When setting the HDR=No option in the connection string, column names are
' automatically generated -- Column A -> F1, Column B -> F2 etc.
' If the first row of your column is the column header, you could specify HDR=Yes
' and use those column headers in SQL

Dim rs As New ADODB.Recordset
rs.Open sql, connectionString

Worksheets("TMP").Range("A1").CopyFromRecordset rs

Answer 4

I think that this code is self explanatory and easy to modify.

Sub Button1_Click()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Const CopyDataOnly As Boolean = False
    Dim c As Long
    Dim c1 As String, c2 As String
    Dim source As Range, target As Range
    With Sheets("Validation by rules")
        For c = 0 To 7
            c1 = Split("A,B,C,G,F,R,S,T", ",")(c)
            c2 = Split("A,B,C,D,E,F,G,H", ",")(c)

            Set source = .Range(.Cells(1, c1), .Cells(.Rows.Count, c1).End(xlUp))
            Set target = Sheets("TMP").Cells(1, c2)
            If CopyDataOnly Then
                target.Resize(source.Rows.Count).Value = source.Value
            Else
                source.Copy target
            End If
        Next
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Answer 5

Approach via Application.Index

This solution demonstrates relatively unknown possibilities of the Application.Index function and allows to restructure the whole array set in one single code line thus avoiding further loops or ReDim(cf. section [3]):

v = Application.Index(v, _
  Application.Evaluate("row(1:" & n - FIRSTROW + 1 & ")"), _
  a)   

Calling procedure

Option Explicit                                  ' declaration head of your code module

Sub CopyColumns()
' Purpose: copy defined columns to target sheet
  Const FIRSTROW& = 2                            ' <<~~ change to first data row
  Dim i&, j&, n&                                 ' row or column counters
  Dim a, v                                       ' variant arrays
  Dim ws As Worksheet, ws2 As Worksheet          ' declare and set fully qualified references
  Set ws = ThisWorkbook.Worksheets("Validation by rules")
  Set ws2 = ThisWorkbook.Worksheets("TMP")
' [1] Get data from A1:T{n}
  n = ws.Range("A" & Rows.Count).End(xlUp).Row   ' find last row number n
  v = ws.Range("A" & FIRSTROW & ":T" & n)        ' get data cols A:T and omit header row(s)
' [2] build columns array (type Long)
  a = buildColAr("A,B,C,F,G,R,S,T")              ' << get wanted column numbers via helper function
' [3] Column Filter A,B,C,F,G,R,S,T
  v = Application.Index(v, _
      Application.Evaluate("row(1:" & n - FIRSTROW + 1 & ")"), _
      a)                                         ' column array
' [4] Copy results array to target sheet, e.g. starting at A2
  ws2.Range("A2").Offset(0, 0).Resize(UBound(v), UBound(v, 2)) = v
End Sub

Helper function buildColAr()

The helper function only offers some further convenience by translating the column names "A,B,C,F,G,R,S,T" to a numbered array 1|2|3|6|7|18|19|20 instead of counting the columns by yourself and assigning values directly, e.g. via parameter Array(1,2,3,6,7,18,19,20)

Function buildColAr(ByVal v As Variant) As Variant
' Purpose: return column number array from splitted string values
' Example: a = buildColAr("A,B,C,F,G,R,S,T") returns 1|2|3|6|7|18|19|20
Dim i&, temp
v = Split(v, ","): ReDim temp(LBound(v) To UBound(v))
For i = LBound(v) To UBound(v)
    temp(i) = Cells(1, v(i)).Column ' get column numbers
Next i
buildColAr = temp
End Function