Giúp em viết macro Merge cell (4 người xem)

[rosy84]

Em có gửi file đính kèm các anh chị giúp em với nha. Thanks!!

 

[ptlong04x1]

Bạn thực hiện thao tác merge cell rồi ghi macro lại là được mà.

 

[rosy84]

ghi lại thì em gi rồi , nhưng khi thực hiện với nhiều dữ liệu khác nhau thì không đựoc.

 

[rollover79]

Bạn thử dùng đoạn code này thử xem sao, cần chọn vùng dữ liệu cần xử lý trước khi chạy nhé.

Sub test()
    Dim rng As Range
    Set rng = Selection
    Dim iRow As Long
    Dim iCol As Long
    Dim iStart As Long
    Dim iStop As Long
    For iCol = 1 To rng.Columns.Count
        iStart = 0
        iStop = 0
        For iRow = 1 To rng.Rows.Count
            If rng.Cells(iRow, iCol) = rng.Cells(iRow + 1, iCol) And iStart = 0 Then iStart = iRow + 1
            If rng.Cells(iRow, iCol) <> rng.Cells(iRow + 1, iCol) Then
                iStop = iRow
                If iStart <> 0 Then
                    Range(rng.Cells(iStart, iCol), rng.Cells(iStop, iCol)).Clear
                    Range(rng.Cells(iStart, iCol), rng.Cells(iStop, iCol)).Merge
                    iStart = 0
                End If
            End If
        Next
    Next
End Sub

 

[SA_DQ]

Bạn kiểm sau khi cho chạy macro ni:

Option Explicit

Sub MerCells()
 Dim Clls As Range, mRng As Range:        Dim eRw As Long
 
 eRw = [a65500].End(xlUp).Row
 For Each Clls In Range("A2:A" & eRw)
   With Clls
      If .Offset(1).Value <> .Value Then
         If mRng Is Nothing Then
            .Offset(, 2) = .Value
         Else
            mRng.Merge:                   Set mRng = Nothing
         End If
      Else
         If mRng Is Nothing Then
            .Offset(, 2) = .Value:        Set mRng = .Offset(1, 2)
         Else
            Set mRng = Union(mRng, .Offset(1, 2))
         End If
      End If
   End With
 Next Clls
End Sub

Chú í khi sử dụng:

Bấm chọn cột 'C' & vô menu Insert để thêm cột tại đó trước khi cho chạy macro (Để có đối chứng )

Bạn nên thấu đáo 1 điều rằng, sau khi trộn ô, sẽ rất khó xài VBA nào đó tiếp sau

 

[rosy84]

Em đã thử rồi 2 macro chạy tốt nhưng macro của rollover79 có lỗi, nhưng không sao , chay vẫn đúng. Cảm ơn các anh chị nhiều nha!!!

 

[rollover79]

Em đã thử rồi 2 macro chạy tốt nhưng macro của rollover79 có lỗi, nhưng không sao , chay vẫn đúng. Cảm ơn các anh chị nhiều nha!!!

Tôi chạy thử code thi không thấy có lỗi gì. Bạn thử post lỗi chi tiết lên xem nguyên nhân do đâu nhé.
Thanks!

 

[rosy84]

Không cần đâu em lam được rồi.

 

[ndu96081631]

Không cần đâu em lam được rồi.

Bạn nói thế không được rồi!
Khi bạn cần thì nhờ người ta làm giúp... các cao thủ đôi khi cũng muốn biết thật ra code của mình đã báo lổi như thế nào ---> Mục đích nhằm hoàn thiện code, cũng như nâng cao kiến thức cho bản thân!
Vậy quan hệ giữa các thành viên là quan hệ song phương: TÔI GIÚP BẠN và BẠN GIÚP TÔI
- Rollover79 giúp bạn tạo code
- Bạn chỉ ra chổ sai của code cũng là giúp cho Rollover79 đấy thôi
Nên bạn không thể vì được việc cho mình mà phát biểu: Không cần đâu em lam được rồi
Đếnlần sau, bạn yêu cầu thì ai thèm giúp
Hãy suy nghĩ xem!

 

[rosy84]

Đây là mã lỗi anh à. Em xin lỗi nha!!!

 

[rosy84]

Em sửa code cua anh như thế này là chạy ngon rồi. Anh xem hộ em nha. Có gì thi chỉ giáo cho em thêm nhé! cảm ơn các anh chị. Thân!!

Sub test()
Dim rng As Range
Set rng = Selection
Dim iRow As Long
Dim iCol As Long
Dim iStart As Long
Dim iStop As Long
k = [a1].End(xlDown).Row
For iCol = 1 To rng.Columns.Count
iStart = 0
iStop = 0
For iRow = 1 To k 'rng.Rows.Count
If Cells(iRow, iCol) = Cells(iRow + 1, iCol) And iStart = 0 Then iStart = iRow + 1
If Cells(iRow, iCol) <> Cells(iRow + 1, iCol) Then
iStop = iRow
If iStart <> 0 Then
Range(Cells(iStart, iCol), Cells(iStop, iCol)).Clear
Range(Cells(iStart, iCol), Cells(iStop, iCol)).Merge
iStart = 0
End If
End If
Next
Next
End Sub

 

[rosy84]

Sub test()
'Dim rng As Range
'Set rng = Selection
Dim iRow As Long
Dim iCol As Long
Dim iStart As Long
Dim iStop As Long
k = [a1].End(xlDown).Row
'For iCol = 1 To rng.Columns.Count
iCol = 1
iStart = 0
iStop = 0
For iRow = 1 To k 'rng.Rows.Count
If Cells(iRow, iCol) = Cells(iRow + 1, iCol) And iStart = 0 Then iStart = iRow + 1
If Cells(iRow, iCol) <> Cells(iRow + 1, iCol) Then
iStop = iRow
If iStart <> 0 Then
Range(Cells(iStart, iCol), Cells(iStop, iCol)).Clear
Range(Cells(iStart, iCol), Cells(iStop, iCol)).Merge
iStart = 0
End If
End If
Next
'Next
End Sub


Cái này cơ anh à.

 

[ndu96081631]

Đây là mã lỗi anh à. Em xin lỗi nha!!!

Bạn không đưa nguyên file Excel đang bị lổi lên đây, đưa cái hình ấy thì biết được gì chứ
(riêng tôi đã test code của bạn Rollover79 nhưng không phát hiện lổi nào)
------------
Bạn Rollover79 có bảo rằng: Phải Select vùng dử liệu trước khi chạy code! Tôi nghĩ có lẻ bạn đã chọn nguyên cột A (thay vì chọn vừa đủ) nên đã phát sinh lổi!
Phán đoán đúng chứ?

 

[rosy84]

OK. đúng anh à, em chọn cả cọt A. thanks