Excel VBA 转置和插入行

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