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

Question

我有一个excelsheet

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 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

Answer 2

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

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 行数据对其进行了测试，代码在不到五秒的时间内完成。

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

Convert multiple columns to a single row based on Column 1 & 2 Values Excel

vba

excel

excel-2007