Làm thế nào để gộp tất cả các ô giống nhau trong một cột vào một ô??? (1 người xem)

[youarenotalone1992]

Chào các bạn! Mình có một bảng tính giống trong file đính kèm nhưng rất nhiều hàng. Lên không làm thủ công được. Bạn nào có thế chỉ giúp mình code VBA để có các ô trùng nhau trong 1 cột sẽ gộp lại không. Giống như trong file mình gửi ý (nhưng khi gộp phải có Alt+enter nhé kiểu wrap text ý). Cảm ơn nhiều<br><br>

 

[phucbugis]

Chào các bạn! Mình có một bảng tính giống trong file đính kèm nhưng rất nhiều hàng. Lên không làm thủ công được. Bạn nào có thế chỉ giúp mình code VBA để có các ô trùng nhau trong 1 cột sẽ gộp lại không. Giống như trong file mình gửi ý (nhưng khi gộp phải có Alt+enter nhé kiểu wrap text ý). Cảm ơn nhiều<br><br>

nếu bạn nghe nói đến hàm JoinText của bác ndu96081631

Ăn cùng GPE, Ở cùng GPE

thì bạn có thể xử lý được trong trường hợp này

'- - - -
công thức đó là công thức mảng -> sau khi nhập xong thì bạn bấm Ctrl+shift+Enter

G3=
{=jointext(CHAR(10);TRUE;IF($A$2:$A$10=E3;$B$2:$B$10;""))}

'- - -
khà khà

Link: https://www.mediafire.com/?y93k1uh3vaihml6

 

[ndu96081631]

nếu bạn nghe nói đến hàm JoinText của bác ntd thì bạn có thể xử lý được trong trường hợp này

Công nhận bác ntd này cũng lắm trò nhỉ?

 

[Let'GâuGâu]

Chào các bạn! Mình có một bảng tính giống trong file đính kèm nhưng rất nhiều hàng. Lên không làm thủ công được. Bạn nào có thế chỉ giúp mình code VBA để có các ô trùng nhau trong 1 cột sẽ gộp lại không. Giống như trong file mình gửi ý (nhưng khi gộp phải có Alt+enter nhé kiểu wrap text ý). Cảm ơn nhiều<br><br>

Góp một đoạn code

Sub ttttt()
Dim Sarr As Variant, KQ(), dic As Object, J As Long
Sarr = Range([a2], [a1000].End(3)).Resize(, 2).Value
ReDim KQ(1 To UBound(Sarr), 1 To 2)
 Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Sarr)
If Not dic.Exists(Sarr(i, 1)) And Not IsEmpty(Sarr(i, 1)) Then
    K = K + 1
     dic.Add Sarr(i, 1), ""
    KQ(K, 1) = Sarr(i, 1)
    KQ(K, 2) = Sarr(i, 2)
Else
J = 1
For Each v In dic.Keys
    If Sarr(i, 1) = v Then KQ(J, 2) = KQ(J, 2) & Chr(10) & Sarr(i, 2)
        J = J + 1
Next
End If
Next
[g2:h100].ClearContents
[g3].Resize(K, 2).Value = KQ
Set dic = Nothing

End Sub

 

[youarenotalone1992]

Góp một đoạn code

Sub ttttt()
Dim Sarr As Variant, KQ(), dic As Object, J As Long
Sarr = Range([a2], [a1000].End(3)).Resize(, 2).Value
ReDim KQ(1 To UBound(Sarr), 1 To 2)
 Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Sarr)
If Not dic.Exists(Sarr(i, 1)) And Not IsEmpty(Sarr(i, 1)) Then
    K = K + 1
     dic.Add Sarr(i, 1), ""
    KQ(K, 1) = Sarr(i, 1)
    KQ(K, 2) = Sarr(i, 2)
Else
J = 1
For Each v In dic.Keys
    If Sarr(i, 1) = v Then KQ(J, 2) = KQ(J, 2) & Chr(10) & Sarr(i, 2)
        J = J + 1
Next
End If
Next
[g2:h100].ClearContents
[g3].Resize(K, 2).Value = KQ
Set dic = Nothing

End Sub

Cảm ơn bạn. code của bạn ra đúng kết quả mình muốn. Nhưng làm thế nào để mình có thể chọn vùng mình cần để chạy code của bạn vậy.

 

[youarenotalone1992]

Cảm ơn bạn nhiều nhưng không đúng ý mình lắm. Chắc do mình truyền đạt kém

 

[Let'GâuGâu]

Cảm ơn bạn. code của bạn ra đúng kết quả mình muốn. Nhưng làm thế nào để mình có thể chọn vùng mình cần để chạy code của bạn vậy.

Sub ttttt()
Dim Sarr As Variant, KQ(), dic As Object, J As Long
[COLOR=#ff0000]Sarr = Range([a2], [a1000].End(3)).Resize(, 2).Value[/COLOR]
.....................................
[g2:h100].ClearContents
[COLOR=#0000ff][g3].Resize(K, 2).Value = KQ[/COLOR]
Set dic = Nothing

End Sub

màu đỏ là nguồn
màu xanh là đích.

nếu muốn merge lại thì code hoàn toàn khác rồi.
chắc là dùng vòng lặp từ trên xuống, cell nào giốn nhau thì merge lại,,nhưng các cell giống nhau fải liên tiếp

 

[youarenotalone1992]

Dữ liệu của mình cũng liên tiếp. Mình cũng loay hoay cái vòng lặp để tìm những ô giống nhau rồi merge mà vẫn chưa ra. haizzz

 

[youarenotalone1992]

Công nhận bác ntd này cũng lắm trò nhỉ?

Sub Macro2()
'
' Macro2 Macro
'
'
Dim i, j As Long
i = 2
j = 0
Do
i = i + j
j = 0
Cells(i, 1).Select
Do While ActiveCell.Value = ActiveCell.Offset(1, 0).Value
j = j + 1
ActiveCell.Offset(1, 0).Select
Loop
Range(Cells(i, 1), _
Cells(i + j, 1)).Merge
If ActiveCell.Value = "" Then Exit Do
Loop
End Sub

Bác thwr xem hộ sao nó không chay cái ạ

 

[Ba Tê]

Cảm ơn bạn. code của bạn ra đúng kết quả mình muốn. Nhưng làm thế nào để mình có thể chọn vùng mình cần để chạy code của bạn vậy.
View attachment 117540

Quét chọn vùng muốn thực hiện, Right Click.
Yêu cầu bắt buộc: chỉ chọn 2 cột, số dòng tối đa là 500

 

[youarenotalone1992]

Quét chọn vùng muốn thực hiện, Right Click.
Yêu cầu bắt buộc: chỉ chọn 2 cột, số dòng tối đa là 500

Code bạn rất đúng ý mình. Nhưng sao lại giới hạn số dòng thế bạn ? Dữ liệu của mình nhiều dòng lắm bạn ơi

 

[Ba Tê]

Code bạn rất đúng ý mình. Nhưng sao lại giới hạn số dòng thế bạn ? Dữ liệu của mình nhiều dòng lắm bạn ơi

Muốn nhiều dòng hơn nữa thì thay dòng thứ 2 trong Sub

If Target.Count > 1 And Target.Count < 1000 Then

Thành như vầy thử xem:

If Target.Rows.Count < 65000 And Target.Columns.Count = 2 Then

Còn chuyện khống chế số dòng, số cột là tại "mắc" khống chế cho "vui" thôi, không khống chế số dòng, số cột có nhiều lúc "buồn" lắm.

 

[youarenotalone1992]

Muốn nhiều dòng hơn nữa thì thay dòng thứ 2 trong Sub

Thành như vầy thử xem:

Còn chuyện khống chế số dòng, số cột là tại "mắc" khống chế cho "vui" thôi, không khống chế số dòng, số cột có nhiều lúc "buồn" lắm.

Good Job, Pro Men