轉換成多列基於列的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