我正在使用以下代码转置并插入数据集的行。
它主要执行我想要的操作，但是它连续插入行，而不考虑列左侧的数据。
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 |
非常感谢您的帮助！
答案 0 :(得分：0)
我的主要假设是，您可以将其作为第二张纸进行操作，而无需处理初始数据，并且不需要插入行。...类似：
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-until循环。在考虑了所有列（成为第二张表上的行）之后，您将移至源表上的下一行。
编辑1：
尽管没有经过测试，但回头并没有考虑到目的地最后一行（dlr），并将其添加到了代码中。
答案 1 :(得分：0)
调整您的代码-查看添加的注释。
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