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

---

Общая вещь, которую я делаю, это вложение цикла для создания новой таблицы на листах («место назначения») на основе данных в листах («источник»), где вы выполняете цикл, делая значение = значение для числа столбцов (после нахождения последнего столбца на исходном листе), который является циклом do-till. После того как вы учли все столбцы (становясь строками на втором листе), вы переходите к следующей строке на исходном листе.

---

Edit1:

Хотя и не проверено, оглянулся назад и не учел пункт назначения последней строки (dlr) и добавил это в код.