[英]Transpose Excel column to rows
I have an Excel sheet that looks like the first picture and I want to convert it to the second picture: 我有一个看起来像第一张图片的Excel工作表,我想将其转换为第二张图片:
I have written the following code but it does not work as expected. 我已经写了下面的代码,但是没有按预期工作。 It deletes more rows than expected. 它删除的行比预期的多。 What's wrong with the code? 代码有什么问题?
Sub Trans3()
Dim rng As Range, rng2 As Range
Dim I As Long
Dim J As Integer, Z As Integer, Q As Integer, T As Integer
Set rng = Range("B1")
While rng.Value <> ""
For Each y In Range("A1:A10")
I = I + 1
J = I
Z = 1
Do While Cells(J + 1, 1).Value = Cells(J, 1).Value
J = J + 1
Loop
Set rng2 = Range("B" & I & ":B" & J)
If I > 1 Then
Z = J - I + 1
Else
Z = J
End If
rng2.Resize(Z).Copy
Range("C" & I).PasteSpecial Transpose:=True
T = I
Do While J > 1
Q = T + 1
Rows(Q).EntireRow.Delete
J = J - 1
Loop
Next y
Wend
End Sub
So I did a little refactoring. 所以我做了一些重构。 I moved everything into arrays to speed it up. 我将所有内容移动到阵列中以加快速度。
See notes in code for reference. 请参阅代码中的注释以供参考。
Sub FOOO()
Dim inArr() As Variant
Dim outArr() As Variant
Dim ws As Worksheet
Dim cntrw As Long
Dim cntclm As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim rng As Range
Set ws = ActiveSheet
With ws
Set rng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
'find the max number column that will be needed in the output
cntclm = ws.Evaluate("MAX(COUNTIF(" & rng.Address & "," & rng.Address & "))") + 1
'find the number of rows that will be needed in the output.
cntrw = ws.Evaluate("SUM(1/COUNTIF(" & rng.Address & "," & rng.Address & "))")
'put the existing data into an an array
inArr = rng.Resize(, 2).Value
'resize output array to the extents needed
ReDim outArr(1 To cntrw, 1 To cntclm)
'put the first value in the first spot in the output
outArr(1, 1) = inArr(1, 1)
outArr(1, 2) = inArr(1, 2)
'these are counters to keep track of which slot the data should go.
j = 3
k = 1
'loop through the existing data rows
For i = 2 To UBound(inArr, 1)
'test whether the data in A has changed or not.
If inArr(i, 1) = inArr(i - 1, 1) Then
'if not put the value in B in the next slot and iterate to the next column
outArr(k, j) = inArr(i, 2)
j = j + 1
Else
'if change start a new line in the outarr and fill the first two slots
k = k + 1
j = 3
outArr(k, 1) = inArr(i, 1)
outArr(k, 2) = inArr(i, 2)
End If
Next i
'remove old data
.Range("A:B").Clear
'place new data in its place.
.Range("A1").Resize(UBound(outArr, 1), UBound(outArr, 2)).Value = outArr
End With
End Sub
This does require that the data be sorted on column A. 这确实要求将数据按A列排序。
My take on this problem . 我对这个问题的看法。
Sub test()
Dim lCtrRow_Raw As Long
Dim lCtrRow_New As Long
Dim lInst As Long
Dim dctUniq As New Dictionary
Dim sKey
Dim arrRaw
Dim arrNew()
'/ Specify your range here. Only two columns of data should be used.
arrRaw = Selection() ' ****Avoid using Selection in actual code****.
'/ Filter Duplicates.
For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw)
If Not dctUniq.Exists(arrRaw(lCtrRow_Raw, 1)) Then
dctUniq.Add arrRaw(lCtrRow_Raw, 1), arrRaw(lCtrRow_Raw, 1)
End If
Next
'/ Start New Array
ReDim arrNew(1 To dctUniq.Count, 1 To 1)
'/ Seed IDs
For Each sKey In dctUniq.Keys
lCtrRow_New = lCtrRow_New + 1
arrNew(lCtrRow_New, 1) = dctUniq(sKey)
Next
'/ Loop and assign unique values
For lCtrRow_New = LBound(arrNew) To UBound(arrNew)
lInst = 1
For lCtrRow_Raw = LBound(arrRaw) To UBound(arrRaw)
If arrRaw(lCtrRow_Raw, 1) = arrNew(lCtrRow_New, 1) Then
lInst = lInst + 1
If lInst > UBound(arrNew, 2) Then
ReDim Preserve arrNew(1 To dctUniq.Count, 1 To lInst)
End If
arrNew(lCtrRow_New, lInst) = arrRaw(lCtrRow_Raw, 2)
End If
Next
Next
'/ Dump array in the data sheet.
'Sheet1.Range("A20").Resize(UBound(arrNew, 1), UBound(arrNew, 2)).Value = arrNew
End Sub
Shank, using your code, I've made minor modifications and now it deletes the right number of rows and it works, try it out. Shank,使用您的代码,我做了一些小的修改,现在它删除了正确的行数,并且可以尝试一下。
Sub Transpose()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet_Name") ' modify here to your Worksheet name
LastRow = sht.Cells(sht.Rows.count, "A").End(xlUp).row
For row = 1 To LastRow
If sht.Cells(row, 1) <> "" Then
i = i + 1
j = i
Z = 1
Do While Cells(j + 1, 1).Value = Cells(j, 1).Value
j = j + 1
Loop
Set rng2 = Range("B" & i & ":B" & j)
If i > 1 Then
Z = j - i + 1
Else
Z = j
End If
rng2.Resize(Z).Copy
Range("C" & i).PasteSpecial Transpose:=True
T = i
Do While j - row > 0
Q = T + 1
Rows(Q).EntireRow.Delete
j = j - 1
Loop
End If
Next
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.