【VBA编程】将有相同值的几条数据行合并成一行

Sub 合并同类项()

 Dim i&, j&, Arr, Brr, Dic As Object

 Set Dic = CreateObject("Scripting.Dictionary")

 Arr = Range(Cells(1, "T"), Cells(Rows.Count, "T").End(xlUp))

 Brr = Arr

 ReDim Brr(0 To UBound(Arr) - 1, 1 To 3)

 For i = 1 To UBound(Arr)

  If Not Dic.Exists(Arr(i, 1)) Then

   Dic(Arr(i, 1)) = Dic.Count

   j = Dic(Arr(i, 1))

   Brr(j, 1) = Arr(i, 1): Brr(j, 2) = Cells(i, "AA"): Brr(j, 3) = Cells(i, "AB")

  Else

   j = Dic(Arr(i, 1))

   Brr(j, 2) = Brr(j, 2) & "," & Cells(i, "AA"): Brr(j, 3) = Brr(j, 3) & "," & Cells(i, "AB")

  End If

 Next i

 [AI1].Resize(Dic.Count, 3) = Brr

 Set Dic = Nothing

End Sub

Sub Macro1()

Set 函数调用 = Application.WorksheetFunction

Sheets(3).Select

Cells.Delete Shift:=xlUp

Sheets(1).Select

He1 = Cells(65536, 1).End(xlUp).Row

Le1 = Cells(1, 256).End(xlToLeft).Column

范围1 = Range(Cells(2, 1), Cells(He1, 1))

Range(Cells(1, 2), Cells(1, Le1)).Copy

Sheets(3).Select

Range(Cells(2, 2), Cells(He1, 2)) = 范围1

Cells(2, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Sheets(2).Select

He2 = Cells(65536, 1).End(xlUp).Row

Le2 = Cells(1, 256).End(xlToLeft).Column

范围2 = Range(Cells(2, 1), Cells(He2, 1))

Range(Cells(1, 2), Cells(1, Le2)).Copy

Sheets(3).Select

Range(Cells(He1 + 1, 2), Cells(He1 + He2 - 1, 2)) = 范围2

Cells(Le1 + 1, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Range(Cells(2, 2), Cells(He1 + He2 - 1, 2)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A2"), Unique:=True

Range(Cells(2, 3), Cells(Le1 + Le2 - 1, 3)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D2"), Unique:=True

Range(Cells(2, 4), Cells(Le1 + Le2 - 1, 4)).Copy

Range("E1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Columns("B:D").Delete Shift:=xlToLeft

He3 = Cells(65536, 1).End(xlUp).Row

Le3 = Cells(1, 256).End(xlToLeft).Column

For H = 2 To He3

Y = Cells(H, 1)

For L = 2 To Le3

X = Cells(1, L)

If 函数调用.CountIf(Sheets(1).Range("A1:A65536"), Y) >0 Then

H1 = 函数调用.Match(Y, Sheets(1).Range("A1:A65536"), 0)

Else

H1 = 0

End If

If 函数调用.CountIf(Sheets(1).Range("A1:IV1"), X) >0 Then

L1 = 函数调用.Match(X, Sheets(1).Range("A1:IV1"), 0)

Else

L1 = 0

End If

If 函数调用.CountIf(Sheets(2).Range("A1:A65536"), Y) >0 Then

H2 = 函数调用.Match(Y, Sheets(2).Range("A1:A65536"), 0)

Else

H2 = 0

End If

If 函数调用.CountIf(Sheets(2).Range("A1:IV1"), X) >0 Then

L2 = 函数调用.Match(X, Sheets(2).Range("A1:IV1"), 0)

Else

L2 = 0

End If

If H1 >0 And L1 >0 Then

Z1 = Sheets(1).Cells(H1, L1)

Else

Z1 = 0

End If

If H2 >0 And L2 >0 Then

Z2 = Sheets(2).Cells(H2, L2)

Else

Z2 = 0

End If

Cells(H, L) = Z1 + Z2

Next

Next

End Sub

假如原始数据在sheet2, 占用sheet2的第5列，用来做标记

Sub Macro1()

For i = 2 To Sheet2.Range("a65536").End(xlUp).Row

Sheet2.Cells(i, 5) = 0

Next i

'先复制第一行数据（标题）

Sheet1.Cells(1, 1) = Sheet2.Cells(1, 1)

Sheet1.Cells(1, 2) = Sheet2.Cells(1, 2)

Sheet1.Cells(1, 3) = Sheet2.Cells(1, 3)

Sheet1.Cells(1, 4) = Sheet2.Cells(1, 4)

n = 2

For j = 2 To Sheet2.Range("a65536").End(xlUp).Row

If Sheet2.Cells(j, 5) = 0 Then

ab = Sheet2.Cells(j, 1)

End If

For i = 2 To Sheet2.Range("a65536").End(xlUp).Row

If Sheet2.Cells(i, 5) = 0 Then

If Sheet2.Cells(i, 1) = ab Then

Sheet2.Cells(i, 5) = 1

Sheet1.Cells(n, 1) = Sheet2.Cells(i, 1)

Sheet1.Cells(n, 2) = Sheet2.Cells(i, 2)

Sheet1.Cells(n, 3) = Sheet2.Cells(i, 3)

Sheet1.Cells(n, 4) = Sheet2.Cells(i, 4)

n = n + 1

End If

End If

Next i

Next j

End Sub

另外也可以在Sub Macro1()后加上

Sheets("Sheet1").Select

  Cells.Select

  Selection.ClearContents

先清除sheet1中的数据，以免以前的数据影响正确显示

---