Question

我有Excel，其中的行数超过5k，代码几乎可以满足我的需要，只是不知道如何实现所需的结果。这是代码：

Sub TransposeInsertRows()

Dim xRg As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Transpose", Type:=8)
Application.ScreenUpdating = False
x = xRg(1, 1).Column + 2
y = xRg(1, xRg.Columns.Count).Column
For i = xRg(xRg.Rows.Count, 1).Row To xRg(1, 1).Row Step -1
    If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
        k = Cells(i, x - 2).End(xlToRight).Column
        If k > y Then k = y
        For j = k To x + 1 Step -1
            Cells(i + 1, 1).EntireRow.Insert
            With Cells(i + 1, x - 2)
                .Value = .Offset(-1, 0)
                .Offset(0, 1) = .Offset(0, 1)
                .Offset(0, 1) = Cells(i, j)
            End With
            Cells(i, j).ClearContents
        Next j
    End If
Next i
Application.ScreenUpdating = True
End Sub

要转置的Excel表行：

01-1-01337-18 |  129 |    21 |  129-2 | 146 |   238

所需结果：

01-1-01337-18   129
01-1-01337-18   21
01-1-01337-18   129-2   
01-1-01337-18   146 
01-1-01337-18   238

现在的结果是：

01-1-01337-18 | 129  |  21
01-1-01337-18 | 129-2|  
01-1-01337-18 | 146  |
01-1-01337-18 | 238  |

我缺少什么？

Answer 1

也许是这样吗？

Sub TransposeInsertRows()

    Dim rData As Range
    Dim aData As Variant
    Dim aResults() As Variant
    Dim iyData As Long, ixData As Long
    Dim iyResult As Long

    On Error Resume Next
    Set rData = Application.InputBox(Prompt:="Range Selection...", _
                                     Title:="Transpose", _
                                     Default:=Selection.Address, _
                                     Type:=8)
    On Error GoTo 0
    If rData Is Nothing Then Exit Sub   'Pressed cancel

    If rData.Cells.Count = 1 Then
        MsgBox "Only one cell selected, not enough data to transpose and insert.  Exiting Macro."
        Exit Sub
    End If

    aData = rData.Value
    ReDim aResults(1 To rData.Rows.Count * rData.Columns.Count, 1 To 2)

    For iyData = 1 To UBound(aData, 1)
        For ixData = 2 To UBound(aData, 2)
            If Len(Trim(aData(iyData, ixData))) > 0 Then
                iyResult = iyResult + 1
                aResults(iyResult, 1) = aData(iyData, 1)
                aResults(iyResult, 2) = aData(iyData, ixData)
            End If
        Next ixData
    Next iyData

    If iyResult = 0 Then
        MsgBox "No data found to transpose in selected range [" & rData.Address & "]"
        Exit Sub
    End If

    rData.Clear
    If rData.Rows.Count < iyResult Then
        rData.Offset(1).Resize(iyResult - rData.Rows.Count - 1).EntireRow.Insert
    End If
    rData.Resize(iyResult, UBound(aResults, 2)).Value = aResults

End Sub

Answer 2

看来x的值是确定是否移动数据。

因此只需将x = xRg(1, 1).Column + 2更改为x = xRg(1, 1).Column + 1

然后k = Cells(i, x - 2).End(xlToRight).Column更改为k = Cells(i, x - 1).End(xlToRight).Column

With Cells(i + 1, x - 2)对With Cells(i + 1, x - 1)的更改应可以按您的意愿工作。

Answer 3

您可能想向后遍历选择行，插入行，用行转置值填充它们并进行一些最终清理：

Sub TransposeInsertRows()
    Dim xRg As Range
    Set xRg = Application.InputBox(Prompt:="Range Selection...", Title:="Transpose", Type:=8)

    Dim iRow As Long
    With xRg ' reference selected range
        For iRow = .Rows.Count To 1 Step -1 ' loop through referenced range rows backwards
            .Rows(iRow + 1).Resize(.Columns.Count - 2).Insert xlShiftDown 'insert n-2 rows down current row
            .Rows(iRow + 1).Resize(.Columns.Count - 2, 1).Value = .Rows(iRow).Cells(1, 1).Value ' populate inserted rows first column with current row first column value
            .Rows(iRow).Offset(1, 1).Resize(.Columns.Count - 2, 1).Value = Application.Transpose(.Rows(iRow).Offset(, 2).Resize(, .Columns.Count - 2).Value) ' populate inserted rows with current row values from 3rd column rightwards 
        Next
        .Columns(3).Resize(, .Columns.Count - 2).ClearContents ' clear columns we already transposed values of
        If WorksheetFunction.CountBlank(.Columns(2)) > 0 Then .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete ' delete rows associated with any missing value 
    End With
End Sub

Excel VBA转置并插入行

3 个答案: