4vuong4tron
Thành viên mới
- Tham gia
- 21/5/18
- Bài viết
- 29
- Được thích
- 3
Có 1 a bên diễn đàn đã viết cod giúp mình (phai mình đã đính kèm ở trên), nhưng khi ấn lựa chon 2 xong các ô công thức mặc định có trong phai (chữ đỏ) đã bị xoá nên khi ấn lại lựa chọn 1 ko còn đúng nữa, nhờ ae giúp bổ sung đoạn cod (khi chọn 2 xong sẽ sửa công thức về như phai gốc ban đầu), mình xin gửi tiền cà phê, ăn sáng
Lưu ý: Lựa chọn 1 là: liên kết ô như hình 2 và Lựa chọn 2 là: trở về hình 1 (như lúc ban đầu)
Dòng cốt của a bên diễn đàn exel đây (phai có cod mình đã đính kèm ở trên):
Option Explicit
Sub merge()
Dim lr&, j&, ip&, cell As Range, celb As Range, bd, ngay
ip = InputBox(" Ban muon merge hay unmerge?" & vbLf & "1: merge" & vbLf & "2: unmerge")
lr = Cells(Rows.Count, "C").End(xlUp).Row
For Each cell In Range("CB10:CB" & lr)
If Not IsEmpty(cell) And IsNumeric(cell) Then
bd = cell + IIf(cell Mod 2 = 0, 1, 0)
ngay = (cell.Offset(, -1).Value - 1) / 2
For Each celb In Range("CD8:FO8")
If celb = bd Then
With Cells(cell.Row, celb.Column)
Application.DisplayAlerts = False
.UnMerge
If ip = 1 Then
.Resize(1, ngay).merge
.Resize(1, ngay).HorizontalAlignment = xlCenter
End If
Application.DisplayAlerts = True
End With
Exit For
End If
Next
End If
Next
End Sub
Lưu ý: Lựa chọn 1 là: liên kết ô như hình 2 và Lựa chọn 2 là: trở về hình 1 (như lúc ban đầu)
Dòng cốt của a bên diễn đàn exel đây (phai có cod mình đã đính kèm ở trên):
Option Explicit
Sub merge()
Dim lr&, j&, ip&, cell As Range, celb As Range, bd, ngay
ip = InputBox(" Ban muon merge hay unmerge?" & vbLf & "1: merge" & vbLf & "2: unmerge")
lr = Cells(Rows.Count, "C").End(xlUp).Row
For Each cell In Range("CB10:CB" & lr)
If Not IsEmpty(cell) And IsNumeric(cell) Then
bd = cell + IIf(cell Mod 2 = 0, 1, 0)
ngay = (cell.Offset(, -1).Value - 1) / 2
For Each celb In Range("CD8:FO8")
If celb = bd Then
With Cells(cell.Row, celb.Column)
Application.DisplayAlerts = False
.UnMerge
If ip = 1 Then
.Resize(1, ngay).merge
.Resize(1, ngay).HorizontalAlignment = xlCenter
End If
Application.DisplayAlerts = True
End With
Exit For
End If
Next
End If
Next
End Sub
