Excel VBA从表中复制单列并转置

Question

我正在尝试从没有标题的表中复制一列并将其转置到工作簿的另一部分。

为此，我采用了一段我以前使用过的代码，但无法完全调整它来做我想做的事情。

我想知道你能不能帮帮我？

我在“工作表 1”中有一个表格，该表格有两列，从单元格“A3”开始。我正在尝试复制不带标题的 B 列，并将其从单元格“J2”转换为“工作表 2”。

我无法通过宏记录器执行此操作，因为如果工作表 1 中的表格只有一行，它不会转入工作表 2，因为它复制了太多单元格（我正在学习更多关于如何避免宏录音机）。

这是我调整过的代码，对我如何更改它或使用更好的代码有任何帮助吗？

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

谢谢

Answer 1

要复制一个范围然后转置粘贴，当然可以使用.Copy 和.PasteSpecial Transpose:=True，但最好调整目标范围的大小，以便改变复制范围的方向，然后将Application.Transpose() 应用于rngCopy.Value。

这段代码应该可以做到。在那里对您的 cmets 进行了一些详细说明，以解释一切的作用。

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

您提到您的范围是一个表格。如果它是一个实际的 Excel 表，您不必担心查找/定义 rngCopy 的第一行和最后一行。您可以将您的范围设置为您想要的特定列的.DataBodyRange（此处为：第 2 列）。像这样：

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

Answer 2

无需使用剪贴板和复制/粘贴操作。我是否直接写入单元格并使用WorksheetFunction.Transpose() 将列变为一行

这是对我有用的代码

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

示例结果