Nhờ giúp về Merge cell bằng VBA (1 người xem)

[Tnhatanh68]

Chào mọi người,

Mình là người mới và mình gặp phải khó khăn cần mọi người giúp đỡ như sau:


File Excel đính kèm thể hiện nội dung thể hiện.
https://drive.google.com/file/d/0B6Cu3xhU93ClWG1VTEExYWVkZnc/view?usp=sharing

Sorry vì mình k đính kèm file được, không biết vì sao.

[TABLE="width: 1103"]
[TR]
[TD]YÊU CẦU thực hiện đối với VBA[/TD]
[/TR]
[TR]
[TD]Từ ô B4 sẽ được merge với những ô "blank" ở dưới nó nếu giá trị cột A cùng hàng tồn tại, có nghĩa là A5 có giá trị, và B5 là "balnk", tương tự với A6 và A7 A8 A9 thì nó sẽ merge lại từ B4 đến B9.[/TD]
[/TR]
[TR]
[TD]Tương tự với giá trị khác "blank" ở cột B, tức là theo như bài toán nó sẽ tự merge từ B10 đến B16[/TD]
[/TR]
[TR]
[TD]Tư merge từ B17 đến B23[/TD]
[/TR]
[TR]
[TD]...[/TD]
[/TR]
[TR]
[TD]Cho đến khi cột A là "Blank" thì sẽ nó sẽ merge đến ô B mà giá trị A tại hàng đó khác "blank"[/TD]
[/TR]
[TR]
[TD]nghĩa là giá trị A75 khác "blank", A76 là "blank" thì hàm sẽ merce từ ô B69 đến B75[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]lưu ý là mỗi ngày sẽ thì thứ tự các ô khác "blank" trong B là khác nhau. Vậy nên yêu cầu của vba là có thể tự lọc và merge lại với nhau một cách tự động.[/TD]
[/TR]
[/TABLE]

Cảm ơn mọi người rất nhiều, chúc một ngày tốt lành.

 

[Ba Tê]

Chào mọi người,

Mình là người mới và mình gặp phải khó khăn cần mọi người giúp đỡ như sau:


File Excel đính kèm thể hiện nội dung thể hiện.
https://drive.google.com/file/d/0B6Cu3xhU93ClWG1VTEExYWVkZnc/view?usp=sharing

Sorry vì mình k đính kèm file được, không biết vì sao.
........................
Cảm ơn mọi người rất nhiều, chúc một ngày tốt lành.

Nếu để in thành báo cáo thì còn được, nếu làm nguồn dữ liệu để sau này trích lọc, tính toán gì đó thì Merge Cells là "tự làm khó mình".

Public Sub GPE()
Dim Rws, I As Long
Application.DisplayAlerts = False
Rws = [A65536].End(xlUp).Row
For I = Rws To 4 Step -1
    If Cells(I, 2) <> Empty Then
        Range("B" & I & ":B" & Rws).Merge
        Rws = I - 1
    End If
Next I
Application.DisplayAlerts = True
End Sub

 

[Tnhatanh68]

Nếu để in thành báo cáo thì còn được, nếu làm nguồn dữ liệu để sau này trích lọc, tính toán gì đó thì Merge Cells là "tự làm khó mình".

Public Sub GPE()
Dim Rws, I As Long
Application.DisplayAlerts = False
Rws = [A65536].End(xlUp).Row
For I = Rws To 4 Step -1
    If Cells(I, 2) <> Empty Then
        Range("B" & I & ":B" & Rws).Merge
        Rws = I - 1
    End If
Next I
Application.DisplayAlerts = True
End Sub

Cảm ơn bạn rất nhiều, vì cái này mình phải in ra theo từng ngày nên dùng hàm cho nhanh

Code VBA mình vừa thử thì có lỗi ở merge từ B69 đến B75. Như mình miêu tả ở trên nó chỉ merge từ ô B có giá trị đến o B có giá trống cuối cùng mà có giá trị A cùng hàng tồn tại (nghĩa là nếu không có giá trị A thì không merge ô B tương ứng đó)

Bạn có thể giúp mình xem lại với được không?
Cảm ơn bạn rất nhiều một lần nữa

Có thể là do cột A file gốc của mình là một hàm if trả ra "" từ bảng dữ liệu nên mới trả kết quả thành như vậy. Bạn có thể giúp mình khắc phục được không?

 

[Ba Tê]

Cảm ơn bạn rất nhiều, vì cái này mình phải in ra theo từng ngày nên dùng hàm cho nhanh

Code VBA mình vừa thử thì có lỗi ở merge từ B69 đến B75. Như mình miêu tả ở trên nó chỉ merge từ ô B có giá trị đến o B có giá trống cuối cùng mà có giá trị A cùng hàng tồn tại (nghĩa là nếu không có giá trị A thì không merge ô B tương ứng đó)

Bạn có thể giúp mình xem lại với được không?
Cảm ơn bạn rất nhiều một lần nữa

Có thể là do cột A file gốc của mình là một hàm if trả ra "" từ bảng dữ liệu nên mới trả kết quả thành như vậy. Bạn có thể giúp mình khắc phục được không?

Thêm 1 vòng lặp để xoá ô rỗng "ma" trước khi Merge:

Public Sub GPE()
Dim Rws, I As Long
Application.DisplayAlerts = False
Rws = [A65536].End(xlUp).Row
For I = 4 To Rws
    If Len(Range("A" & I)) = 0 Then Range("A" & I).ClearContents
Next I
Rws = [A65536].End(xlUp).Row
For I = Rws To 4 Step -1
    If Cells(I, 2) <> Empty Then
        Range("B" & I & ":B" & Rws).Merge
        Rws = I - 1
    End If
Next I
Application.DisplayAlerts = True
End Sub