CODEWITHSUNDEEP
excelvba
Bikat Uprety
Bikat Uprety

Reputation: 139

Excel VBA copy single column from table and transpose

I'm trying to copy a column from a table without it's header and transposing it into another part of the workbook.

To do so I've taken a piece of code that I've used before but can't quite tweak it to do what I want.

I was wondering if you could please help me?

I have table in "sheet 1" that has two columns and starts in cell "A3". I'm trying to copy column B, without the header, and transpose it into "sheet 2" from the cell "J2".

I can't do it via the macro recorder because if the table in sheet 1 only has one row it won't transpose into sheet 2 because it copies too many cells (and I'm learning more on how to avoid macro recorder).

This is the code I've tweaked, any help on how I can change it or use a better code?

'
' Macro21 Macro

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

    'Set variables for copy and destination sheets
    Set wsCopy = Worksheets("Sheet1")
    Set wsDest = Worksheets("Sheet2")
    
    '1. Find last used row in the copy range based on data in column 1
    lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row
    
    '2 Find first bnak row in the destination range based in column B
    lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
    
    '3. Copy & Paste Data
    
    wsCopy.Range("B4").Copy wsDest.Range("J2" & lDestLastRow)
End Sub

Thanks

Upvotes: 1

Views: 1277

Answers (2)

jalex
jalex

Reputation: 1524

No need to use the clipboard and copy/paste operations. Do I direct write to cells and use WorksheetFunction.Transpose() to make the column into a row

Here is the code that worked for me

Option Explicit

Public Sub TestCopy()

    CopyColumnTransposedTo
        Sheets("Sheet1").Range ("A3"), _
        2, _
        Sheets("Sheet2").Range("J2")

End Sub

Public Sub CopyColumnTransposedTo(ByVal r_table As Range, column As Long, ByVal r_destination As Range)
    ' Move to the column on table
    Set r_table = r_table.Cells(1, column)
    ' Count rows from end
    Dim ws As Worksheet
    Set ws = r_table.Worksheet
    Dim count As Long
    count = ws.Cells(ws.Rows.count, r_table.column).End(xlUp).Row - r_table.Row + 1
    If count > 0 Then
        ' Copy transpose to destination
        r_destination.Resize(1, count) = _
            WorksheetFunction.Transpose( _
                r_table.Resize(count, 1).Value)
    End If
End Sub

Example results

scr1

scr2

Upvotes: 0

ouroboros1
ouroboros1

Reputation: 14144

To copy a range and then paste it transposed, you can of course use .Copy and .PasteSpecial Transpose:=True, but it will be much better to resize your destination range in such a way that you shift the orientation of your copy range, and then to apply Application.Transpose() to the rngCopy.Value.

This code should do it. Some elaboration on your comments in there to explain what everything does.

Sub TransposeRangeColumn()

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

Dim rngCopy As Range

    'Set variables for copy and destination sheets
    Set wsCopy = Worksheets("Sheet1")
    Set wsDest = Worksheets("Sheet2")
    
    '1. Find last used row in the copy range based on data in column B (!? you had "column 1")
    lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row
    
    '2. Set rngCopy
    Set rngCopy = wsCopy.Range("B4:B" & lCopyLastRow)
        
    '3. a) Resize destRang transposed. Example:
        'Range("A1").Resize(RowSize=2, ColumnSize=3) would get you Range("A1:C2")
        'we need to transpose, so input .Resize(rngCopy.ColumnSize, rngCopy.RowSize) instead
        'we have 1 column, so just use 1 for the row; for columns, count rows rngCopy
    
        'b) now that we have a transposed destination range, we want to set its value equal to
        'a transposed version of rngCopy using Application.Transpose()
    
    wsDest.Range("J2").Resize(1, rngCopy.Rows.Count).Value = Application.Transpose(rngCopy.Value)

    'Code below would also have worked, but try to grow accustomed to using .Value = .Value instead
    'it gives way better performance
    
    'rngCopy.Copy
    'wsDest.Range("J2").PasteSpecial Transpose:=True, Paste:=xlPasteValues

End Sub

You mentioned that your range is a table. If it is an actual Excel Table, you don't have to worry about finding/defining the first and last row of rngCopy. You can just set your range to the .DataBodyRange of the specific column you want (here: Column 2). Like this:

Sub TransposeTableColumn()

'Transpose if it's an actual table

Dim wsCopy As Worksheet
Dim wsDest As Worksheet

Dim rngCopy As Range

Set wsCopy = Worksheets("Sheet1")
Set wsDest = Worksheets("Sheet2")

'Use your table name instead of "Table1"
Set rngCopy = wsCopy.ListObjects("Table1").ListColumns(2).DataBodyRange

wsDest.Range("J2").Resize(1, rngCopy.Rows.Count) = Application.Transpose(rngCopy.Value)

End Sub

Upvotes: 2

Related Questions