将Excel列转换为行 [英] Transpose Excel column to rows

问题描述

我有一张Excel表，看起来像第一张照片，我想把它转换成第二张图片：

我已经写了下面的代码，但是没有按预期的方式工作。它删除比预期更多的行。代码有什么问题？

  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 
 
设置rng = Range（B1）
虽然rng.Value< ;> 
 
对于每个y范围（A1：A10）
 I = I + 1 
 J = I 
 Z = 1 
虽然单元格（J + 1，1）.Value =单元格（J，1）.Value 
 J = J + 1 
循环
设置rng2 =范围（B& ;：B& J）
 
如果我> 1然后
 Z = J  -  I + 1 
 Else 
 Z = J 
如果
 
 rng2.Resize（Z）.Copy 
 Range（C& I）.PasteSpecial Transpose：= True 
 T = I 
 
 Do While J> 1 
 Q = T + 1 
行（Q）.EntireRow.Delete 
 J = J  -  1 
循环
 
下一个y 
 Wend 
 
 End Sub 
  

解决方案

所以我做了一点重构。

请参阅代码中的附注。

  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 
 
设置ws = ActiveSheet 
 
用ws 
设置rng = .Range（A1，.Cells（.Rows.Count，A）。End（xlUp））
'找到最大数字列这将需要在输出
 cntclm = ws.Evaluate（MAX（COUNTIF（& rng.Address&，& rng.Address&）））+ 1 
'找到输出中需要的行数。 
 cntrw = ws.Evaluate（SUM（1 / COUNTIF（& rng.Address&，& rng.Address&）））
'将现有数据放入一个数组
 inArr = rng.Resize（，2）.Value 
'将大小输出数组调整到所需的区域
 ReDim outArr（1 To cntrw，1 To cntclm）
'将第一个值放在输出的第一个位置
 outArr（1，1）= inArr（1，1）
 outArr（1，2）= inArr（1，2）
'这些是计数器来跟踪数据应该去哪个时隙。 
j = 3 
k = 1 
'循环通过现有数据行
对于i = 2 To UBound（inArr，1）
'测试A中的数据是否改变与否
如果inArr（i，1）= inArr（i  -  1，1）然后
'如果没有将值放在下一个插槽中的B中，并迭代到下一列
 outArr（k ，j）= inArr（i，2）
j = j + 1 
 Else 
'如果更改在outarr中开始一个新行并填写前两个插槽
k = k + 1 
j = 3 
 outArr（k，1）= inArr（i，1）
 outArr（k，2）= inArr（i，2）
 End If 
 Next i 
'删除旧数据
 .Range（A：B）。清除
'将新数据放在其位置。 
 .Range（A1）。调整大小（UBound（outArr，1），UBound（outArr，2））Value = outArr 
 End with 
 End Sub 
  

这样做需要将数据排在A列。

I have an Excel sheet that looks like the first picture and I want to convert it to the second picture:

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.

这篇关于将Excel列转换为行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！