Xử lý trùng (TKB)

[aviaiva]

Tiết trùng (chữ đỏ blod)
Nhờ các bác viết hộ code xử lý tiết trùng trên TKB.

Tiết trùng: cùng 1 tiết của 1 buổi dạy có 2 giáo viên cùng dạy
(trên hình: tiết 2 ngày thứ 2 lớp 12C7 bị trùng tiết)
Cách xử lý tay:
VD trường hợp lớp 12C7
Xét xem trong số tiết còn lại của thứ 2 (tiết 1, 3,4,5) tiết nào chưa có giáo viên dạy thì chuyển 12C7 sang ô đó
=> có 2 trường hợp xảy ra:
- TH1: (chuyển 12C7 ở hàng 15) Ô chuyển đến là ô trống (xóa dữ liệu ở ô cũ chuyển sang ô mới) => coi như xử lý xong
- TH2: Ô chuyển đến là ô chứ dữ liệu (VD chuyển lớp 12C7 của hàng 28) khi đó sẽ đổi chỗ hai ô dữ liệu cho nhau. => xảy ra 2 trường hợp
TH2.1: sau khi đổi chỗ không còn trùng dữ liệu
TH2.2: sau khi đổi chỗ 12C7 hết trùng, nhưng ô dữ liệu mới lại trùng => lại quay lại xử lý từ đầu như trường hợp 1 đến khi không còn trùng thì thôi.

(các tiết CC, SH không được di chuyển)

Dữ liệu trong bảng trên đã thỏa mãn điều kiện còn chỗ trống để di chuyển.

Nhờ các bác giúp đỡ

 

[nhapmon]

mình chạy thấy nó đã khử hết màu đỏ rồi đó, không biết có xài được ko,
cái này dùng mảng chắc hay hơn, nhưng mình không biết sử dụng chỉ xài for ....nẽt thôi,
bạn chạy thử sub này nha

Sub TimLopTrung()
Application.ScreenUpdating = False
Dim lw As Long
Dim i, j As Integer
Dim sh As Worksheet

Set sh = Sheets("GVS")
lw = Range("A" & Rows.Count).End(xlUp).Row
For j = 5 To 33
For i = 4 To lw 'Find duplicates from the list.
If Application.CountIf(Range(Cells(i, j), Cells(lw, j)), Cells(i, j).Text) > 1 And Cells(i, j) <> "" Then
If j < 27 Or j > 28 Then
Cells(i, j).Offset(0, 1).Value = Cells(i, j).Value
Cells(i, j).ClearContents
ElseIf j = 27 Then
Cells(i, j).Offset(0, 2).Value = Cells(i, j).Value
Cells(i, j).ClearContents
End If
End If
Next i
Next j
Application.ScreenUpdating = True
End Sub

 

[aviaiva]

mình chạy thấy nó đã khử hết màu đỏ rồi đó, không biết có xài được ko,
cái này dùng mảng chắc hay hơn, nhưng mình không biết sử dụng chỉ xài for ....nẽt thôi,
bạn chạy thử sub này nha
End Sub

code của bác xóa mất vài tiết trùng chứ không phải xử lý tiết trùng triệt để(di chuyển lớp bị trùng đến một vị trí không trùng trong 1buổi (1thứ) ), rất cảm ơn bác nhưng vẫn không phải câu trả lời cho bài toán trên.

vẫn mong các bác giúp đỡ

 

[nhapmon]

nó dời đi mà anh,ví dụ ở cell E15 tôi gõ vào 12C7, chạy code thấy nó dời qua H15.
tuy nhiên có nhiên cái nó dời qua tuần khác luôn..hiiihiii.
thôi đợi cao thủ giúp anh vậy há.....

 

[aviaiva]

bác nào dùng công thức mảng giúp đỡ, em dùng for chạy dọc rồi chạy ngang cũng tàm tạm nhưng chạy chậm quá code của em đây, nhờ các bác tối ưu hộ

[GPECODE=vb]Sub XulyTietTrung1()
Vung = Application.CountA(Range("a4:a304")) + 2
Set wf = WorksheetFunction
Set Sh = ActiveSheet
For J = 4 To 33
cot1 = J + 1 - Cells(3, J)
cot2 = J + 5 - Cells(3, J)
For I = 4 To Vung
If wf.CountIf(Range(Cells(4, J), Cells(Vung, J)), Cells(I, J)) > 1 And Cells(I, J) <> "" And _
Cells(I, J) <> "CC" And Cells(I, J) <> "SH" And (wf.CountIf(Range(Cells(4, cot1), Cells(Vung, cot2)), _
Cells(I, J)) + wf.CountIf(Range(Cells(I, cot1), Cells(I, cot2)), "SH") + _
wf.CountIf(Range(Cells(I, cot1), Cells(I, cot2)), "CC")) <= 5 Then
Cells(I, "ak") = Cells(I, J)
If Cells(I, "ak") <> "" Then
For K = J + 1 To cot2
If wf.CountIf(Range(Cells(4, K), Cells(Vung, K)), Cells(I, J)) = 0 And _
Cells(I, K) <> "CC" And Cells(I, K) <> "SH" And Cells(I, "ak") <> "" Then
Cells(I, J) = Cells(I, K)
Cells(I, K) = Cells(I, "ak")
Cells(I, "ak").ClearContents
Else
End If
Next
Else
End If
If Cells(I, "ak") <> "" Then
For K = cot1 To J - 1
If wf.CountIf(Range(Cells(4, K), Cells(Vung, K)), Cells(I, J)) = 0 And _
Cells(I, K) <> "CC" And Cells(I, K) <> "SH" And Cells(I, "ak") <> "" Then
Cells(I, J) = Cells(I, K)
Cells(I, K) = Cells(I, "ak")
Cells(I, "ak").ClearContents
Else
End If
Next
Else
End If
Else
End If
Next
Next
End Sub[/GPECODE]