Excel VBA 转置和插入行，困惑

Question

我使用以下代码为数据集转置和插入行。

它主要做我想要的，但它连续插入行，而不考虑列左侧的数据。

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

我的 excel 数据如下所示

Other Data | Data to transpose | Data to transpose |...
----------------------------------------------------------------------------------
xyz123     |     telephone     |     123           | 312 | 123 | 334|
oij        |    faxmachine     |   129             |  22 |  3  | 
lowks      |    fridge         |     32            |   1 |  55 |  928|  239|

我希望它看起来像

   Other Data | Data to transpose | Data to transpose |...
    ----------------------------------------------------------------------------------
    xyz123     |    telephone     |     123  |
               |    telephone      |      312 |  
               |    telephone     |      123 |
               |    telephone      |     334  |
    oij        |    faxmachine     |   129  |      
               |    faxmachine     |    22  |
               |    faxmachine     |    3   |
    lowks      |    fridge         |     32 |     
               |    fridge         |     1  |
               |    fridge         |     55  |
               |    fridge         |     928 |
               |    fridge         |     239 |

目前我最终得到的是以下内容：

 ...Other Data | Data to transpose | Data to transpose |...
        ----------------------------------------------------------------------------------
        xyz123     |    telephone     |     123  |
                   |    telepone      |      312 |  
                   |    telephone     |      123 |
                   |    telehone      |     334  |
                   |    faxmachine     |   129  |      
                   |    faxmachine     |    22  |
                   |    faxmachine     |    3   |
                   |    fridge         |     32 |     
                   |    fridge         |     1  |
                   |    fridge         |     55  |
                   |    fridge         |     928 |
                   |    fridge         |     239 |
        oij        |
        lowks      |

非常感谢您的帮助！

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 3) 'need 3 columns, not 2
    iyResult = 1
    For iyData = 1 To UBound(aData, 1)
        aResults(iyResult, 1) = aData(iyData, 1)      'xyz123 etc moe outside loop so doesn't repeat every row
        For ixData = 3 To UBound(aData, 2)                    'start at 3, as 2 is telephone etc
            If Len(Trim(aData(iyData, ixData))) > 0 Then
                aResults(iyResult, 2) = aData(iyData, 2)      'telephone etc
                aResults(iyResult, 3) = aData(iyData, ixData) 'numbers
                iyResult = iyResult + 1
            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

我最大的假设是，您可以将其作为第二张纸来执行此操作，而不会触及您的初始数据，并且不需要插入行......像这样：

dim sws as worksheet, dws as worksheet, i as long, j as long, k as long, slr as long, dlr as long, lc as long
set sws = sheets("source")
set dws = sheets("desination")
with sws
    slr = .cells(.rows.count,2).end(xlup).row
    for i = 1 to slr 
        lc = .cells(i,.columns.count).end(xltoleft).column
        j = 3
        dlr = dws.cells(dws.rows.count,2).end(xlup).row+1
        dwb.cells(j,1)
        do until j = lc
            dwb.cells(dlr,2).value = .cells(i,2).value
            dwb.cells(dlr,3).value = .cells(i,j).value
            j = j+1
            dlr = dlr+1
        loop
    next i
end with

---

我正在做的一般事情是嵌套一个循环，以根据工作表("源"(中的数据在工作表("目标"(上创建一个新表，其中您正在循环执行 value=value 的列数(在找到源工作表上的最后一列之后(，这是 do-till 循环。 考虑完所有列(成为第二个工作表上的行(后，您将移动到源工作表上的下一行。

---

编辑1：

尽管没有经过测试，但回头看了看，没有考虑目标最后一行(dlr(并将其添加到代码中。