Viết Code Di Chuyển Kí Tự (1 người xem)

[vuongtoituonglai]

Viết Code Phân Công Lịch Trực

Chào anh/chị và các bán
Mình có 1 file excel cần di chuyển kí tự theo điều kiện, rất mong các anh chị và các bạn giúp dùm.
Tất cả nội dung mô tả đều có trong file
Chân thành cảm ơn

 

[gtri]

Cảm ơn bạn, Tháng 11, 12/2015 code chạy cho kết quả đúng qua tháng 01/2016 khi chạy code thì các chữ "O" bị xóa hết và khi chạy code của những tháng đã qua chữ "O" cũng bị xóa hết.
Bạn kiểm tra code và chỉnh sửa dùm mình chổ này nhé.

sorry, lỗi do xác định số cột tính toán bị thừa. Sửa lại code
Bạn xem file đính kèm

Public Sub Lich_Truc()
Dim Thu, Lich, kq(), r As Long, c As Long, i

With Sheet1
r = .Range("C7").End(xlDown).Row
For c = 5 To .Range("D5").End(xlToRight).Column   'sửa chỗ này
If Val(.Cells(5, c)) > Val(.Cells(5, c + 1)) Then Exit For
Next c

.Range("D7", "AH" & r).ClearContents
Thu = .Range(.Cells(6, 4), .Cells(6, c))
Lich = .Range("AK7", "AK" & r)
ReDim kq(1 To r, 1 To c - 3)   'sửa chỗ này

For c = 1 To UBound(Thu, 2)
If Right(Thu(1, c), 1) <> 7 And Application.Trim(Thu(1, c)) <> "C N" Then
i = i + 1
For r = 1 To UBound(Lich)
If Lich(r, 1) = i Then kq(r, c) = "O": Exit For
Next r
End If
Next c

.Range("D7").Resize(UBound(kq), UBound(kq, 2)) = kq
End With
End Sub

 

[vuongtoituonglai]

sorry, lỗi do xác định số cột tính toán bị thừa. Sửa lại code
Bạn xem file đính kèm

Public Sub Lich_Truc()
Dim Thu, Lich, kq(), r As Long, c As Long, i

With Sheet1
r = .Range("C7").End(xlDown).Row
For c = 5 To .Range("D5").End(xlToRight).Column   'sửa chỗ này
If Val(.Cells(5, c)) > Val(.Cells(5, c + 1)) Then Exit For
Next c

.Range("D7", "AH" & r).ClearContents
Thu = .Range(.Cells(6, 4), .Cells(6, c))
Lich = .Range("AK7", "AK" & r)
ReDim kq(1 To r, 1 To c - 3)   'sửa chỗ này

For c = 1 To UBound(Thu, 2)
If Right(Thu(1, c), 1) <> 7 And Application.Trim(Thu(1, c)) <> "C N" Then
i = i + 1
For r = 1 To UBound(Lich)
If Lich(r, 1) = i Then kq(r, c) = "O": Exit For
Next r
End If
Next c

.Range("D7").Resize(UBound(kq), UBound(kq, 2)) = kq
End With
End Sub

Cảm ơn bạn, mình đặt hàm COUNTA tại dòng số 30 nhưng mỗi lần chạy code đều bị xóa vậy phải điều chỉnh code như thế nào.
Mong bạn giúp đỡ.

 

[gtri]

Cảm ơn bạn, mình đặt hàm COUNTA tại dòng số 30 nhưng mỗi lần chạy code đều bị xóa vậy phải điều chỉnh code như thế nào.
Mong bạn giúp đỡ.

Bạn dán cái này thay thế code cũ là được.
Khi viết code nghĩ là dòng và cột có hàm counta() không cần thiết nên hơi ẩu
Có lẽ thế này là ổn thôi.

Public Sub Lich_Truc()
Dim Thu, Lich, kq(), r As Long, c As Long, i

With Sheet1
r = .Range("C7").End(xlDown).Row

For c = 5 To .Range("D5").End(xlToRight).Column
If Val(.Cells(5, c)) > Val(.Cells(5, c + 1)) Then Exit For
Next c

.Range("D7", "AH" & (r - 6)).ClearContents
Thu = .Range(.Cells(6, 4), .Cells(6, c))
Lich = .Range("AK7", "AK" & r)
ReDim kq(1 To r - 6, 1 To c - 3)

For c = 1 To UBound(Thu, 2)
If Right(Thu(1, c), 1) <> 7 And Application.Trim(Thu(1, c)) <> "C N" Then
i = i + 1
For r = 1 To UBound(Lich)
If Lich(r, 1) = i Then kq(r, c) = "O": Exit For
Next r
End If
Next c

.Range("D7").Resize(UBound(kq), UBound(kq, 2)) = kq
End With
End Sub

 

[vuongtoituonglai]

Bạn dán cái này thay thế code cũ là được.
Khi viết code nghĩ là dòng và cột có hàm counta() không cần thiết nên hơi ẩu
Có lẽ thế này là ổn thôi.

Public Sub Lich_Truc()
Dim Thu, Lich, kq(), r As Long, c As Long, i

With Sheet1
r = .Range("C7").End(xlDown).Row

For c = 5 To .Range("D5").End(xlToRight).Column
If Val(.Cells(5, c)) > Val(.Cells(5, c + 1)) Then Exit For
Next c

.Range("D7", "AH" & (r - 6)).ClearContents
Thu = .Range(.Cells(6, 4), .Cells(6, c))
Lich = .Range("AK7", "AK" & r)
ReDim kq(1 To r - 6, 1 To c - 3)

For c = 1 To UBound(Thu, 2)
If Right(Thu(1, c), 1) <> 7 And Application.Trim(Thu(1, c)) <> "C N" Then
i = i + 1
For r = 1 To UBound(Lich)
If Lich(r, 1) = i Then kq(r, c) = "O": Exit For
Next r
End If
Next c

.Range("D7").Resize(UBound(kq), UBound(kq, 2)) = kq
End With
End Sub

Cảm ơn bạn nhé. Mình thấy đã ổn rồi để mình test nhiều tình huống khác nhau nếu có vấn đề nhờ bạn tiếp tục giúp đỡ.