Question

我有一张excel表

A AAA 1
A AAA 2
A AAA 3
A ABC 1
A ABC 2
B AAA 1
B AAA 2
B AAA 3
B ABC 1
B ABC 2

我需要它看起来像

A AAA 1 2 3
A ABC 1 2
B AAA 1 2 3
B ABC 1 2

我有此代码转换

A 1 2 3
A 1
A 2
A 3

但找不到反向

Sub MakeOutput()

    Dim iInputRow As Long
    Dim iInputColumn As Long
    Dim iOutputRow As Long

    iOutputRow = 1 '- counter for which row to paste to
    '- loop through each row on the input sheet
    For iInputRow = 1 To Sheets("Input").Range("A" & Sheets("Input").Rows.Count).End(xlUp).Row
        '- loop through each column inside of each row
        For iInputColumn = 2 To Sheets("Input").Cells(iInputRow, 1).End(xlToRight).Column
            Sheets("Output").Range("A" & iOutputRow).Value = Sheets("Input").Range("A" & iInputRow).Value
            Sheets("Output").Range("B" & iOutputRow).Value = Sheets("Input").Cells(iInputRow, iInputColumn).Value
            iOutputRow = iOutputRow + 1
        Next iInputColumn
    Next iInputRow

End Sub

Answer 1

此代码将避免一次写入一个单元并使用数组来大大加快处理时间：

Sub tgr()

    Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim ACell As Range
    Dim arrResults() As Variant
    Dim ResultIndex As Long
    Dim sCurrent As String
    Dim sLine As String

    Set wsInput = ActiveWorkbook.Sheets("Input")
    Set wsOutput = ActiveWorkbook.Sheets("Output")

    With wsInput.Range("A1").CurrentRegion
        .Sort .Resize(, 1), xlAscending, .Offset(, 1).Resize(, 1), , xlAscending, Header:=xlGuess
        ReDim arrResults(1 To .Cells.Count, 1 To 1)
        For Each ACell In .Resize(, 1).Cells
            If ACell.Value & "|" & ACell.Offset(, 1).Value <> sCurrent Then
                sCurrent = ACell.Value & "|" & ACell.Offset(, 1).Value
                ResultIndex = ResultIndex + 1
                arrResults(ResultIndex, 1) = sCurrent
            End If
            arrResults(ResultIndex, 1) = arrResults(ResultIndex, 1) & "|" & ACell.Offset(, 2).Value
        Next ACell
    End With

    With wsOutput.Range("A1").Resize(ResultIndex)
        .Parent.UsedRange.Clear
        .Value = arrResults
        .TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="|"
    End With

End Sub

我使用超过325,000行数据对其进行了测试，并且代码在不到五秒的时间内完成。

Answer 2

这对你有用。这有点令人头疼：）

Sub CustomTranspose()
    Dim i As Long, j As Long
    Dim num As Long
    Dim m As Long: m = 1
    For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
        ''The next line of code will show what line you are on 
        ''in the status bar at the bottom of the excel window
        Application.StatusBar = "Processing row " & i & " of " & Rows.Count

        num = 0
        For j = 1 To Range("A" & Rows.Count).End(xlUp).Row
            If Range("A" & i).Value = Range("A" & j).Value And Range("B" & i).Value = Range("B" & j).Value Then
                If i <> j Then
                    Range("D" & j).Value = "duplicate"
                End If
                num = num + 1
            End If
        Next j
        If Range("D" & i).Value <> "duplicate" Then
            Range("A" & i & ":B" & i).Copy Destination:=Sheet2.Range("A" & m)
            For k = 1 To num
                Sheet2.Cells(m, 3 + k - 1).Value = Range("C" & i + k - 1).Value
            Next k
            m = m + 1
        End If
    Next i

    ''This line clears the StatusBar
    Application.StatusBar = False
End Sub

根据第1列和第1列将多列转换为单行。 2值Excel

2 个答案: