Question

我有一张看起来像第一张照片的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

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

Answer 1

所以我做了一点重构。我将所有内容都移到阵列中以加快速度。

请参阅代码中的注释以供参考。

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

这确实要求数据在A列上排序。

Answer 2

我对这个问题的看法。

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

Answer 3

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

将Excel列转置为行

3 个答案: