转换成多列基于列的1＆2个值的Excel

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行数据，代码在不到5秒的时间内完成。

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