Trộn các ô theo điều kiện

[nhoc2012]

Các pro giúp mình tạo một đoạn macro thực hiện trộn các ô theo điều kiện cho trước (xem file sẽ rõ hơn). Mình làm tay thì được nhưng khi danh sách dài và nhiều thì làm hơi lâu và bất tiện quá. Mong các pro giúp mình ha.

 

[Quang_Hải]

Bạn xem file đính kèm

 

[TrungChinhs]

Các pro giúp mình tạo một đoạn macro thực hiện trộn các ô theo điều kiện cho trước (xem file sẽ rõ hơn). Mình làm tay thì được nhưng khi danh sách dài và nhiều thì làm hơi lâu và bất tiện quá. Mong các pro giúp mình ha.

Bạn thử file này xem.

Sub MergeCell()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    On Error Resume Next
    
    With Range("a4:a" & [b65000].End(3).Row).SpecialCells(4)
        For i = 1 To .Areas.Count
            For j = 1 To 2
                .Areas(i)(0, j).Resize(.Areas(i).Rows.Count + 1).Merge
            Next
        Next
    End With
End Sub

 

[nhoc2012]

sao e áp dụng cho các danh sách khác thì lại không được vậy?? Có cách nào áp dụng cho bất cứ danh sách nào mà nội dung thì cũng chỉ Merge 2 cột "STT" và "ho va ten KH" ??

 

[TrungChinhs]

Code này áp dụng cho bất kỳ danh sách nào với điều kiện cột STT phải ở cột A và danh sách bắt đầu từ dòng 4 (y như ví dụ bạn đã gửi). Nếu danh sách nào không thực hiện được thì bạn trích gửi File lên.

 

[tranduyquang2511]

Bạn thử file này xem.

Sub MergeCell()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    On Error Resume Next
    
    With Range("a4:a" & [b65000].End(3).Row).SpecialCells(4)
        For i = 1 To .Areas.Count
            For j = 1 To 2
                .Areas(i)(0, j).Resize(.Areas(i).Rows.Count + 1).Merge
            Next
        Next
    End With
End Sub

Thầy giải thích code giúp em với được không. Code thầy viết hay quá, mà em đọc không luận ra nổi. Cảm ơn thầy.

 

[concogia]

sao e áp dụng cho các danh sách khác thì lại không được vậy?? Có cách nào áp dụng cho bất cứ danh sách nào mà nội dung thì cũng chỉ Merge 2 cột "STT" và "ho va ten KH" ??

Có
Miễn là cột "STT" rồi đến cột "Họ & Tên KH" là nó "chơi" láng. Bạn thử chạy code này ( xin phép mượn luôn code của bạn TrungChinhs )

Sub MergeCell()
Dim I, J, Vung
    Application.DisplayAlerts = False
    On Error Resume Next
    Set Vung = Application.InputBox("Chon Cot TEN", "Chon vung muon tron", , , , , , 8)
    With Vung.Offset(, -1).Resize(, 2).SpecialCells(4)
        For I = 1 To .Areas.Count
            For J = 1 To 2
                With .Areas(I)(0, J).Resize(.Areas(I).Rows.Count + 1)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .MergeCells = True
                End With
            Next
        Next
    End With
End Sub

Khi chạy code sẽ xuất hiện một bảng, bạn chọn cột dữ liệu "Họ & Tên Khách hàng" ==> Enter
Thí dụ, trong file của bạn ở bài #1, bạn chọn vùng B3:B25 ==> Enter
Thân

 

[TrungChinhs]

Thầy giải thích code giúp em với được không. Code thầy viết hay quá, mà em đọc không luận ra nổi. Cảm ơn thầy.

Híc... Bạn đọc không hiểu sao biết là hay ? đọc xong bài của bạn tôi chẳng biết là nên vui hay nên buồn nữa đây !

 

[nhoc2012]

Cảm ơn mọi người nha, mọi người xem giúp e file này với, e chạy hoài mà không được, nhân tiện nhờ mọi người giải thích hộ e nội dung 2 code này luôn nha, e mới làm quen với VBA nên còn "mù" lắm.

 

[concogia]

Cảm ơn mọi người nha, mọi người xem giúp e file này với, e chạy hoài mà không được, nhân tiện nhờ mọi người giải thích hộ e nội dung 2 code này luôn nha, e mới làm quen với VBA nên còn "mù" lắm.

Không chạy được là vì trong cột A ở sheet1 những cell thấy nó rỗng nhưng thật ra nó .......hổng có rỗng, còn nó là gì thì mình hông biết.
Vì code của bạn TrungChinhs viết dựa theo các cell trống làm chuẩn nên mình phải "thịt" hết những cái gì ở trong các cell đó thì code mới chịu chạy. Bạn xem ở sheet2, mình copy sang dữ liệu của bạn sang rồi chạy code
Dữ liệu gốc vẫn ở sheet1
Muốn thử, bạn copy dữ liệu sheet1 sang một sheet mới, đứng ở sheet đó bấm Ctrl + q ( code này sẽ làm cho những cell thấy rỗng thành....rỗng thật) rồi chạy code trong bài sẽ có kết quả Ok
Thân

 

[nhoc2012]

Không chạy được là vì trong cột A ở sheet1 những cell thấy nó rỗng nhưng thật ra nó .......hổng có rỗng, còn nó là gì thì mình hông biết.
Vì code của bạn TrungChinhs viết dựa theo các cell trống làm chuẩn nên mình phải "thịt" hết những cái gì ở trong các cell đó thì code mới chịu chạy. Bạn xem ở sheet2, mình copy sang dữ liệu của bạn sang rồi chạy code
Dữ liệu gốc vẫn ở sheet1
Muốn thử, bạn copy dữ liệu sheet1 sang một sheet mới, đứng ở sheet đó bấm Ctrl + q ( code này sẽ làm cho những cell thấy rỗng thành....rỗng thật) rồi chạy code trong bài sẽ có kết quả Ok
Thân

Cảm ơn nhiều ha, để em làm thử

 

[nhoc2012]

Không chạy được là vì trong cột A ở sheet1 những cell thấy nó rỗng nhưng thật ra nó .......hổng có rỗng, còn nó là gì thì mình hông biết.
Vì code của bạn TrungChinhs viết dựa theo các cell trống làm chuẩn nên mình phải "thịt" hết những cái gì ở trong các cell đó thì code mới chịu chạy. Bạn xem ở sheet2, mình copy sang dữ liệu của bạn sang rồi chạy code
Dữ liệu gốc vẫn ở sheet1
Muốn thử, bạn copy dữ liệu sheet1 sang một sheet mới, đứng ở sheet đó bấm Ctrl + q ( code này sẽ làm cho những cell thấy rỗng thành....rỗng thật) rồi chạy code trong bài sẽ có kết quả Ok
Thân

Em làm được rồi, cảm ơn "sư phụ" nhiều ha, nó rất có ích cho công việc của em. Sẵn đây e mạo phạm xin sư phụ giả thích dùm đoạn code luôn, mới tập tành VBA nên không hiểu nhiều lắm

 

[TrungChinhs]

Không chạy được là vì trong cột A ở sheet1 những cell thấy nó rỗng nhưng thật ra nó .......hổng có rỗng, còn nó là gì thì mình hông biết.Vì code của bạn TrungChinhs viết dựa theo các cell trống làm chuẩn nên mình phải "thịt" hết những cái gì ở trong các cell đó thì code mới chịu chạy. Bạn xem ở sheet2, mình copy sang dữ liệu của bạn sang rồi chạy codeDữ liệu gốc vẫn ở sheet1Muốn thử, bạn copy dữ liệu sheet1 sang một sheet mới, đứng ở sheet đó bấm Ctrl + q ( code này sẽ làm cho những cell thấy rỗng thành....rỗng thật) rồi chạy code trong bài sẽ có kết quả OkThân

Tôi thường gọi các ký tự không nhìn thấy là "rác trắng" và đây đoạn code làm cho những cell "rỗng" thành rỗng thật sự

Sub XoaRacTrang()    
On Error Resume Next
    With Range("a3:a" & [b65000].End(3).Row)
        .AutoFilter 1, "="
        .ClearContents
        .AutoFilter
    End With
End Sub

Vì vậy để chắc ăn bạn gọi Sub này trước câu lệnh With Vung như sau:

Call XoaRacTrang
With Vung.Offset(, -1).Resize(, 2).SpecialCells(4)
...