Cần nối các ô với nhau (Nếu có ô trùng thì chỉ nối 1 ô trùng nằm bên trên cao nhất) (1 người xem)

[hung2412]

Xin chào các Anh chị và các bạn GPE!
Nhờ các Anh chị và các bạn giúp đỡ cho tôi vấn đề này với, cụ thể như sau:
Dọc theo cột B có các ô trống màu vàng xen kẽ như vầy:

=> Mong muốn của tôi là: Làm thế nào để nối các ô bên trên ô màu vàng? (Kết quả nối được đặt vào ô màu vàng bên dưới các ô được nối) (Nếu có các ô trùng nhau thì chỉ nối 1 ô duy nhất được lấy từ ô bên trên cao nhất trong các ô trùng nhau đó)
Ví dụ:
[TABLE="width: 300"]
[TR]
[TD="align: center"]152[/TD]
[TD="align: center"]621[/TD]
[/TR]
[TR]
[TD="align: center"]133111[/TD]
[TD="align: center"]622[/TD]
[/TR]
[TR]
[TD="align: center"]133111[/TD]
[TD="align: center"]622[/TD]
[/TR]
[TR]
[TD="align: center"][/TD]
[TD="align: center"]621[/TD]
[/TR]
[TR]
[TD="align: center"][/TD]
[TD="align: center"]642[/TD]
[/TR]
[TR]
[TD="align: center"][/TD]
[TD="align: center"]133111[/TD]
[/TR]
[TR]
[TD="align: center"]↓[/TD]
[TD="align: center"]↓[/TD]
[/TR]
[TR]
[TD="align: center"]152, 133111[/TD]
[TD="align: center"]621, 622, 642, 133111[/TD]
[/TR]
[/TABLE]

Kết quả mong muốn như hình dưới đây:

Mong các Anh chị và các bạn GPE chỉ giáo!
Trân trọng cảm ơn!
P/s: Có 01 File đính kèm.

 

[phihndhsp]

ý tưởng:
biến tam kiểu chuỗi đầu tiên trống
tam=""
duyệt từ đầu đến cuối
nếu
ô nào không trống thì xử lý bước 1
ô nào trống thì xử lý bước 2
bước 1:
kiểm tra giá trị đã tồn tại chưa
nếu chưa tồn tại thì ghép lại tam= tam & chuoi
bước 2:
Lưu biến tam tại nơi gặp điều kiện đúng
gán lại biến tam = ""

đó là ý tưởng, bạn có thể theo đó mà tìm hoặc tự tìm cho mình ý tưởng khác

 

[Quang_Hải]

Code kiểu này cho rắc rối chút. Ai thích thì nghiên cứu cho vui. Không thích thì coi như spam

 

[SA_DQ]

Thêm 1 hướng đi cho bạn: Vòng lặp nhảy cóc

Đầu tiên bạn chạy macro này:

Sub Macro1()
 Dim Rng As Range, Cls As Range
  
 Rows("3:3").Insert
 Set Rng = Range([B2], [B65500].End(xlUp).Offset(1)).SpecialCells(xlCellTypeBlanks)
 For Each Cls In Rng
    MsgBox Cls.Address
 Next Cls
End Sub

Sau đó bạn chạy macro này:

Sub Macro2()
 Dim Rng As Range, Cls As Range, Rg0 As Range
  
 Rows("3:3").Insert
 Set Rng = Range([B2], [B65500].End(xlUp).Offset(1)).SpecialCells(xlCellTypeBlanks)
 For Each Cls In Rng
    Set Rg0 = Range(Cls.Offset(1), Cls.End(xlDown).Offset(-1))
    MsgBox Rg0.Address
 Next Cls
End Sub

Đến đây bạn sẽ thấy là:
Tốc độ sẽ fải nhanh hơn duyệt từng ô
& chuyện còn lại của bạn fải là:
Bạn tìm cách thoát trước khi kết thúc vòng lặp 1 bước (Khi ô đầu tiên của Rg0 mới vượt ô cuối cùng của Rng)
Tạo vòng lặp duyệt trong vùng Rg0 & ghi kết quả vô ô trống tiếp theo
Xóa dòng "3:3" đã thêm vô ban đầu.

 

[Hau151978]

Sub ABC()
    Dim n&, s$, arr(), i&
    n = Range("B65536").End(xlUp).Row + 1
    arr = Range("B3:B" & n).Value2
    For i = 1 To n - 2
        If arr(i, 1) = "" Then
            arr(i, 1) = s
            s = ""
        ElseIf InStr(s & ",", arr(i, 1) & ",") = 0 Then
            s = IIf(s = "", arr(i, 1), s & ", " & arr(i, 1))
        End If
    Next
    Range("D3:D" & n) = arr
End Sub

 

[phihndhsp]

Sub ABC()
    Dim n&, s$, arr(), i&
    n = Range("B65536").End(xlUp).Row + 1
    arr = Range("B3:B" & n).Value2
    For i = 1 To n - 2
        If arr(i, 1) = "" Then
            arr(i, 1) = s
            s = ""
        [B]ElseIf InStr(s & ",", arr(i, 1) & ",") = 0 Then[/B]
            s = IIf(s = "", arr(i, 1), s & ", " & arr(i, 1))
        End If
    Next
    Range("D3:D" & n) = arr
End Sub

xem lại cái này nha
ElseIf InStr(s & ",", arr(i, 1) & ",") = 0 Then
bạn nên cần xử lý lại cái Elseif

 

[Hau151978]

xem lại cái này nha
ElseIf InStr(s & ",", arr(i, 1) & ",") = 0 Then
bạn nên cần xử lý lại cái Elseif

Ý bạn là phải dùng
Else
If...
End If?
Trường hợp này cả 2 đều như nhau, cách mình làm lại gọn hơn.

 

[phihndhsp]

Ý bạn là phải dùng
Else
If...
End If?
Trường hợp này cả 2 đều như nhau, cách mình làm lại gọn hơn.

bạn chay thử dãy số này xem sao
111,11,1,2,3, đáp số của bạn sẽ bị sai

 

[Hau151978]

bạn chay thử dãy số này xem sao
111,11,1,2,3, đáp số của bạn sẽ bị sai

Đúng là mình sai, phải thêm dấu ", " ở trước nữa. Code sửa lại thành
ElseIf Instr(", " & s & ",",", " & arr(i, 1) & ",")>0 then.....

 

[hung2412]

Nhờ các bạn chỉ giáo mà tôi viết được Code cùi:
[GPECODE=vb]Sub Noi_o_duoi()
Dim Tam
Dim Dic As Object
Dim i As Long
Set Dic = CreateObject("Scripting.Dictionary")
For i = 3 To [B65536].End(xlUp).Offset(1, 0).Row
If Cells(i, 2) <> "" Then
If Not Dic.exists(Cells(i, 2).Value) Then
Dic.Add Cells(i, 2).Value, Empty
Tam = Tam & ", " & Cells(i, 2)
End If
Else
Cells(i, 2) = Right(Tam, Len(Tam) - 2)
Tam = Empty
Dic.RemoveAll
End If
Next
End Sub[/GPECODE]
Note: Ở đây tôi không khoe khoang gì cả (Tôi sẽ lưu Đề tài này dưới dạng Off), chỉ là tôi muốn cuối mỗi đề tài của tôi tổng kết lại Code để tiện cho việc lần sau tôi vào lấy thông tin thì không phải lọc lại từ đầu. Trân thành cảm ơn tất cả.