Question

我有88213行数据，范围从11到21列。

传统上复制和粘贴数据不起作用。

我在这里阅读了很多脚本，但是没有人建议将行转换为列的常见脚本（或者如果你愿意，可以将列转换为行）。

有人可以帮我怎么做？

我试过这个，但循环不起作用：

Sub Transponse()

    Dim wrkSht As Worksheet
    Dim lLastCol As Long
    Dim lLastRow As Long
    Dim i As Long

    'Work through each sheet in the workbook.
    'For Each wrkSht In ThisWorkbook.Worksheets
     For j = 1 To lLastRow
        'Find the last column on the sheet.
        lLastCol = LastCell(wrkSht).Column

        'Work through each column on the sheet.
        For i = 1 To lLastCol

            'Find the last row for each column.
            lLastRow = LastCell(wrkSht, i).Row

            'Remove the duplicates.
            With wrkSht
                .Range(.Cells(1, i), .Cells(j, i)).Select
                 Selection.Copy
                 Sheets("Tabelle2").Select
                 Range(.Cells(j, 1)).Select
                 Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                 False, Transpose:=True
            End With
        Next i

    Next j
    'Next wrkSht

    Range("A1:K1").Select
    Selection.Copy
    Sheets("Tabelle2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

End Sub

'This function will return a reference to the last cell in either the sheet, or specified column on the sheet.
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

Answer 1

在Excel中有一个内置的操作来处理它... 另外，您可能应该使用包含这么多记录的数据库。

事实上，我需要更新我的答案。 Excel仅支持16384列。因此，您无法将88213行翻转到列空间中。

以下是2007年至2016年的Microsoft Excel规范...... https://support.office.com/en-us/article/excel-specifications-and-limits-1672b34d-7043-467e-8e27-269d656771c3

您还可以在Excel帮助中搜索Transpose Rows。这是内容......

以下是：

{{1}}

Answer 2

这应该可以解决问题（它为您转置的每张纸创建一张新纸张）：

Sub Transpose_All_Sheets()
    Dim tB As Workbook
    Dim wS As Worksheet
    Dim DestWS As Worksheet
    Dim LastRow As Double
    Dim EndCol As Integer
    Dim i As Long
    Dim j As Long

    Set tB = ThisWorkbook

    For Each wS In tB.Sheets
        If Left(wS.Name, 2) <> "T_" Then
            Set DestWS = tB.Sheets.Add
            DestWS.Name = "T_" & wS.Name
            LastRow = LastRow_1(wS)
            For i = 1 To LastRow
                EndCol = wS.Cells(i, wS.Columns.Count).End(xlToLeft).Column
                wS.Range(wS.Cells(i, 1), wS.Cells(i, EndCol)).Copy DestWS.Cells(1, i)
            Next i
        Else
        End If
    Next wS

MsgBox "done"
End Sub

使用：

Public Function LastRow_1(wS As Worksheet) As Double
    With wS
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            LastRow_1 = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
        Else
            LastRow_1 = 1
        End If
    End With
End Function

Answer 3

我认为这样的事情应该有用（假设您的数据在表单（1）上，并希望将所有内容复制到表单（2））：

Option Explicit
Sub test()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer

    i = 1
    While Sheets(1).Cells(1, i).Value <> ""
        j = 1
        While Sheets(1).Cells(j, i).Value <> ""
            Sheets(2).Cells(i, j) = Sheets(1).Cells(j, i)
            j = j + 1
        Wend
        i = i + 1
    Wend
End Sub

在下表中继续的另一个版本。

请注意，这不会创建工作表，因此您需要在运行之前获得所需数量的工作表。
它不会在工作表上重复您的标题

两条经过评论的行用于测试目的

选项明确子测试（） Dim i As Double Dim j As Double Dim k As Double

i = 1
k = 2
While Sheets(1).Cells(1, i).Value <> ""
    j = 1
    While Sheets(1).Cells(j + (k - 2) * 16384, i) <> ""
        If j <= (k - 1) * 16384 Then
            'Sheets(k).Cells(i, j).Select
            Sheets(k).Cells(i, j) = Sheets(1).Cells(j + (k - 2) * 16384, i)
        Else
            j = 0
            k = k + 1
            'Sheets(k).Activate
        End If
        j = j + 1
    Wend
    k = 2
    i = i + 1
Wend
End Sub

以及清理行中重复项的小事（有82000行不会那么快）：

Sub Eraser()
    Dim i As Double
    Dim j As Double
    Dim k As Double
    i = 1
    While Sheets(1).Cells(i, 1).Value <> ""
        j = 1
        While Sheets(1).Cells(i, j).Value <> ""
            k = j + 1
            While Sheets(1).Cells(i, k).Value <> ""
                If Sheets(1).Cells(i, j).Value = Sheets(1).Cells(i, k).Value Then
                    Sheets(1).Cells(i, k).Delete Shift:=xlToLeft
                    k = k - 1
                End If
                k = k + 1
            Wend
            j = j + 1
        Wend
        i = i + 1
    Wend
End Sub

VBA excel将许多行转换为具有不同大小的列

3 个答案: