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

使用VBA将行复制到列中

3 个答案: