VBA以行的形式更改excel数据转置

Question

我输入如下

1   10
2   20
3   30
1   40
2   50
4   60
1   80

和输出，如果有多个匹配对应的值应该如下。

1   10  40  80
2   20  50  
3   30      
4   60      

Answer 1

A1：B7

1   10
2   20
3   30
1   40
2   50
4   60
1   80


Sub copyit()
Dim LastRow As Long
Dim myRange, MyRange1 As Range
LastRow = Cells(Rows.count, "A").End(xlUp).Row
For X = 1 To LastRow
For Y = 1 + X To LastRow
If Cells(X, 1).Value = Cells(Y, 1).Value Then
If MyRange1 Is Nothing Then
Set MyRange1 = Rows(Y).EntireRow
Rows(X).End(xlToRight).Offset(, 1).Value = Cells(Y, 2).Value
Else
Set MyRange1 = Union(MyRange1, Rows(Y).EntireRow)
Rows(X).End(xlToRight).Offset(, 1).Value = Cells(Y, 2).Value
End If
End If
Next
Next
MyRange1.Select
Selection.Delete
End Sub

或。 。

Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet

Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop

Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Names"
Cells(1, 2).Value = "Results"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")
End Sub