Macro Merge dữ liệu (1 người xem)

[bugatino]

Chào các bạn GPE,

Dưới đây là hình miêu tả yêu cầu của mình:

Mình có 1 bảng dữ liệu, trong đó cột A chứa ngày diễn ra sự kiện, cột B là loại sự kiện sẽ diễn ra. Mình muốn gộp các dữ liệu trùng nhau lại để cho dễ nhìn. Mong nhận được sự giúp đỡ của các bạn.

 

[nguyenthuy13388]

bạn xem đây có đúng với yêu cầu không nhé:

 

[bugatino]

Cám ơn bạn nguyenthuy13388 nhưng mình cần giải pháp VBA hơn. Đây chỉ là 1 phần trong bảng mình cần tính vì vậy mình cần macro VBA để có thể giải quyết vấn đề này.

 

[nghiaphuc]

Cám ơn bạn nguyenthuy13388 nhưng mình cần giải pháp VBA hơn. Đây chỉ là 1 phần trong bảng mình cần tính vì vậy mình cần macro VBA để có thể giải quyết vấn đề này.

Có ngay đây:
[GPECODE=vb]Sub MergeData()
Dim First As Range, Last As Range
Application.DisplayAlerts = False: Application.ScreenUpdating = False
Sheets("Sheet1").Activate
[A1].CurrentRegion.AdvancedFilter 2, , [I1:J1], True
Set First = [I2]
Do
Set Last = [I:I].Find(First, First, xlValues, xlWhole, 2)
With Range(First, Last)
.Merge: .VerticalAlignment = xlCenter
End With
Set First = First.End(xlDown)
Loop Until First.Row = Cells.Rows.Count
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub[/GPECODE]

 

[bugatino]

Cám ơn bạn Nghiaphuc. Mình cần VBA gộp dữ liệu cho ra kết quả như hình minh họa mình gửi phía trên. Bạn giúp mình sửa lại code với.

 

[nghiaphuc]

Cám ơn bạn Nghiaphuc. Mình cần VBA gộp dữ liệu cho ra kết quả như hình minh họa mình gửi phía trên. Bạn giúp mình sửa lại code với.

Thế thì dùng code này vậy:
[GPECODE=vb]Sub MergeData_1()
Dim First As Range, Last As Range
Application.DisplayAlerts = False: Application.ScreenUpdating = False
Sheets("Sheet1").Activate
[I2:J65000].Clear
[A1].CurrentRegion.Resize(, 2).Copy [I1]
Set First = [I2]
Do
Set Last = First
Do While Last.Offset(1) = Last
Set Last = Last.Offset(1)
Loop
With Range(First, Last)
.Merge: .VerticalAlignment = xlCenter
End With
Set First = First.End(xlDown)
Loop Until First.Row = Cells.Rows.Count
Set First = [J2]
Do
Set Last = First
Do While Last.Offset(1, -1) = "" And Last.Offset(1) = Last
Set Last = Last.Offset(1)
Loop
With Range(First, Last)
.Merge: .VerticalAlignment = xlCenter
End With
Set First = First.End(xlDown)
Loop Until First.Row = Cells.Rows.Count
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub[/GPECODE]
Chắc chắn về tốc độ thì code này không thể nhanh bằng code ở cách trên được, tuy nhiên nếu bạn thực sự muốn kết quả như vậy thì cũng đành chấp nhận chậm một chút vậy.

 

[bugatino]

Bạn nghiaphuc giúp mình sửa lại code VBA 1 chút sao cho khi mình chạy thì nó sẽ gộp dữ liệu luôn ở range gốc (cột A, B) thay vì gộp dữ liệu ở cột I,J như code trên với. Cám ơn bạn!

 

[nghiaphuc]

Bạn nghiaphuc giúp mình sửa lại code VBA 1 chút sao cho khi mình chạy thì nó sẽ gộp dữ liệu luôn ở range gốc (cột A, B) thay vì gộp dữ liệu ở cột I,J như code trên với. Cám ơn bạn!

Chuyện này quá đơn giản, khỏi cần copy đi đâu hết. Code sửa lại như sau:
[GPECODE=vb]Sub MergeData_2()
Dim First As Range, Last As Range
Application.DisplayAlerts = False: Application.ScreenUpdating = False
Sheets("Sheet1").Activate
Set First = [A2]
Do
Set Last = First
Do While Last.Offset(1) = Last
Set Last = Last.Offset(1)
Loop
With Range(First, Last)
.Merge: .VerticalAlignment = xlCenter
End With
Set First = First.End(xlDown)
Loop Until First.Row = Cells.Rows.Count
Set First = [B2]
Do
Set Last = First
Do While Last.Offset(1, -1) = "" And Last.Offset(1) = Last
Set Last = Last.Offset(1)
Loop
With Range(First, Last)
.Merge: .VerticalAlignment = xlCenter
End With
Set First = First.End(xlDown)
Loop Until First.Row = Cells.Rows.Count
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub[/GPECODE]