使用VBA将行复制到列中

Question

我对VBA的经验很少，并且非常感谢您提供有关此问题的帮助。 我需要将行转换为从工作表1到工作表2的列。

输入文件

期望的输出

样本数据

我的密码

Sub TransposeSpecial()

    Dim lMaxRows As Long 'max rows in the sheet
    Dim lThisRow As Long 'row being processed
    Dim iMaxCol As Integer 'max used column in the row being processed

    lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row

    lThisRow = 2 'start from row 2

    Do While lThisRow <= lMaxRows

        iMaxCol = Cells(lThisRow, Columns.Count).End(xlToLeft).Column

        If (iMaxCol > 1) Then
            Rows(lThisRow + 1 & ":" & lThisRow + iMaxCol - 1).Insert
            Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Copy
            Range("C" & lThisRow + 1).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Clear
            lThisRow = lThisRow + iMaxCol - 1
            lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
        End If

        lThisRow = lThisRow + 1
    Loop
End Sub

通过代码获得的输出

所需的输出

Answer 1

在这里，我做了这个灵活的代码。 只需在开始时更新变量。

Sub Transpose_my_cells()
  Dim rng As Range
  Dim sheet1, sheet2, addr As String
  Dim src_top_row, src_left_col, dst_top_row, dst_left_col, data_cols, y As Integer
  Application.ScreenUpdating = False


    sheet1 = "Sheet1"    'Put your source sheet name here
    sheet2 = "Sheet2"    'Put your destiny sheet name here

    src_top_row = 1     'Put the top row number of the source here
    src_left_col = 1    'Put the left col number of the source here

    dst_top_row = 1     'Put the top row number of the destiny here
    dst_left_col = 1    'Put the left col number of the destiny here

    'Count data columns
    data_cols = 0
    Do Until Worksheets(sheet1).Cells(src_top_row, src_left_col + data_cols + 1) = ""
        data_cols = data_cols + 1
    Loop

    'start copying data
    With Worksheets(sheet1)
    'first header
        .Cells(src_top_row, src_left_col).Copy
        addr = Cells(dst_top_row, dst_left_col).Address
        Worksheets(sheet2).Range(addr).PasteSpecial

        y = 0
            'loop for each source row
            Do Until .Cells(src_top_row + y + 1, src_left_col) = ""

                'Create First column repetitions
                .Cells(src_top_row + y + 1, src_left_col).Copy
                addr = Cells(dst_top_row + y * data_cols + 1, dst_left_col).Address & ":" & Cells(dst_top_row + y * data_cols + data_cols, dst_left_col).Address
                Worksheets(sheet2).Range(addr).PasteSpecial

                'Transpose Data Headers
                addr = Cells(src_top_row, src_left_col + 1).Address & ":" & Cells(src_top_row, src_left_col + data_cols).Address
                .Range(addr).Copy
                Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 1).PasteSpecial Transpose:=True

                'Transpose Data columns
                Set rng = Cells(src_top_row + y + 1, src_left_col + 1)
                addr = rng.Address & ":" & rng.Offset(0, data_cols - 1).Address
                .Range(addr).Copy
                Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 2).PasteSpecial Transpose:=True
                y = y + 1
            Loop

    End With

  Application.ScreenUpdating = True
End Sub

Answer 2

使用VBA：

Sub Transpose_my_cells()
    Worksheets("Sheet1").Range("A1:E1").Copy
    Worksheets("Sheet2").Range("A1").PasteSpecial Transpose:=True

End Sub

笔记：

• 更改Sheet1和Sheet2的工作表名称，如VBA工作表列表中所示。
• 将A1：E1更改为源单元格范围
• 将A1更改为命运顶部单元格

Answer 3

可能有一种更容易/更清洁的方法来执行此操作，但是它可以工作。 现在的编写方式将在Sheet1中获取数据，并在Sheet2中输出转置后的数据。 只要您的数据在单元格A1中开始，它就应该起作用。

Option Explicit

Sub transpose()

    Dim names() As String
    Dim count As Long
    Dim i As Long
    Dim j As Long
    Dim rng As Range
    Dim tmp As Long

    Sheets("Sheet1").Activate

    count = 0
    With ThisWorkbook.Sheets("Sheet1")
        Do Until .Cells(1, 2 + count) = ""
            count = count + 1
        Loop

        ReDim names(0 To count - 1)
        count = 0
        Do Until .Cells(1, 2 + count) = ""
            names(count) = .Cells(1, 2 + count).Value
            count = count + 1
        Loop
        .Range("A2").Activate
        Set rng = Range(Selection, Selection.End(xlDown))
    End With

    j = 0
    With ThisWorkbook.Sheets("Sheet2")
        .Cells(1, 1).Value = "ID"
        .Cells(1, 2).Value = "Name"
        .Cells(1, 3).Value = "Value"
        For i = 0 To rng.count * count - 1
            If i Mod count = 0 Then
                j = j + 1
                Range(Cells(j + 1, 2), Cells(j + 1, count + 1)).Copy
                .Cells(i + 2, 3).PasteSpecial transpose:=True
            End If
            .Cells(i + 2, 1).Value = rng(j).Value
            .Cells(i + 2, 2).Value = names(i Mod count)
        Next i
        .Activate
    End With

End Sub