Xếp TKB tự động bằng excel (nhờ tối ưu code)

[aviaiva]

Em đã sắp giải xong bài toán xếp TKB tự động bằng excel, tuy nhiên code viết toàn dùng vòng lặp nên càng ngày chương trình càng lớn và có nguy cơ tăng thời gian thực hiện.

Vì trình độ có hạn về VBA nên nhờ các bác tối ưu các đoạn code em đã thực hiện. (em sẽ trình bày chi tiết yêu cầu từng đoạn, từng đoạn, nhờ các bác phân tích và cho ý kiến bổ xung, sửa chữa và giúp đỡ em có được những đoạn code ngắn gọn và công lực hơn )

Cơ bản dữ liệu chính nằm ở shet data,
shet GVS, GVC tương tự nhau.
shet TKb học sinh không cần bàn vì code của bac concogia gọn đẹp rồi.

Em sẽ nhờ từng đoạn, nếu các bác thấy có tối ưu cũng không hơn hoặc không thể gọn hơn thì nói em bỏ qua để em post tiếp.

Giai đoạn 1: xếp randum vị trí và randum lớp cho các giáo viên
Các yêu cầu cần đạt được
- Giáo viên chọn là ngẫu nhiên
- Lớp của giáo viên đó cũng được chọn là ngẫu nhiên
- Xếp vào vị trí ngẫu nhiên trong phần nguyện vọng đăng ký
- Không có trùng tiết
- Không có 3 tiết trong 1 buổi (nếu có yêu cầu về cặp tiết thì cố gắng cho 2 tiết gần nhau là cùng 1 lớp).


cách em đã thực hiện như sau:

Sub RanGV()
ChaySub = True
Range("cp4:cp304").ClearContents
Cells(3, "cp") = Application.CountA(Range("a4:a304"))
Range(Cells(4, "cp"), Cells(3 + Cells(3, "cp"), "cp")) = RandNum(4, Cells(3, "cp") + 3, Cells(3, "cp")) ‘tạo ra các số ngẫu nhiên không trùng tương ứng với vị trí hàng ngang của từng giáo viên
End Sub

Sub xepTKBgv1()
ChaySub = True
Set Sh = ActiveSheet
Set wf = WorksheetFunction
    If Sh.Name = "GVS" Then
        Set rng1 = Sheets("data").Range("b4:v73")  ‘chứa tên các lớp sáng
        Set rng2 = Sheets("data").Range("b3:v3") ‘ chứa tên môn học
        Set rng3 = Sheets("data").Range("b4:b73") ‘chứa bảng số về tiết dạy ứng với môn ứng với lớp
Vung = Application.CountA(Range("a4:a304")) + 3
RanGV
For I = 4 To vung
    hgv = Cells(I, "cp") ‘ số hàng ngẫu nhiên không trùng  
        If Cells(hgv, 2) <> "" Then
            Range("cq4:cq300").ClearContents
            Range(Cells(4, "cq"), Cells(3 + Cells(hgv, 62), "cq")) = RandNum(41, 40 + Cells(hgv, 62), Cells(hgv, 62)) ‘ tạo ra số ngẫu nhiên ứng với cột lớp
            Range("cr4:cr40").ClearContents
            Range("cr4:cr9") = RandNum(1, 6, 6) ‘ tạo ra số ngẫu nhiên ứng với các thứ 
            For J = 4 To 3 + Cells(hgv, 62)
                cL = Cells(J, "cq")
                If wf.CountIf(rng3, Cells(hgv, cL)) = 1 Then
                    For K = 4 To 29 Step 5
                        vt = Cells((K - 4) / 5 + 4, "cr") * 5 – 1 ‘lấy ngẫu nhiên các cột 4, 9, 14, 19, 24, 29 là cột bắt đầu ứng với các thứ trên bảng TKB giáo viên cần xếp
                        If Cells(hgv, 93) <> 0 Then ‘ xét điều kiện cặp tiết
                            For M = vt To vt + 4
                               If Cells(hgv, M + 59) <> 0 ‘ xét nguyện vọng
And Cells(hgv, M) = "" And  

wf.CountIf(Range (Cells(4, M), Cells(Vung, M)), Cells(hgv, cL)) < 1 And ‘đảm bảo dữ liệu trong cột là duy nhất

wf.CountIf(Range(Cells(hgv, vt), Cells(hgv, vt + 4)), Cells(hgv, cL)) < 2 And ‘ đảm bảo tổng dữ liệu trong hàng <2

wf.CountIf(Range(Cells(hgv, 4), Cells(hgv, 33)), Cells(hgv, cL)) < wf.VLookup(Cells(hgv, cL),  rng1, wf.Match(Cells(hgv, 3), rng2, 0), 0) ‘
đảm bảo tổng số tiết trên hàng bằng với số tiết đã cho
Then
                                    Cells(hgv, M) = Cells(hgv, cL).Value
 ‘phía dưới tương tự
                        If Cells(hgv, 93) = 0 Then ‘ xét điều kiện không có cặp tiết
                            For M = vt To vt + 4
                               If Cells(hgv, M + 59) <> 0 And Cells(hgv, M) = "" And wf.CountIf(Range _
                                (Cells(4, M), Cells(Vung, M)), Cells(hgv, cL)) < 1 And wf.CountIf(Range( _
                                Cells(hgv, vt), Cells(hgv, vt + 4)), Cells(hgv, cL)) < 1 And wf.CountIf(Range( _
                                Cells(hgv, 4), Cells(hgv, 33)), Cells(hgv, cL)) < wf.VLookup(Cells(hgv, cL), _
                                rng1, wf.Match(Cells(hgv, 3), rng2, 0), 0) Then
                                    Cells(hgv, M) = Cells(hgv, cL).Value

dùng hàm RandNum sẵn có trong GPE

Function RandNum(Btom As Long, Top As Long, Amount As Long)ReDim aa(Amount) As Long     Do        bb = Int(Rnd() * (Top - Btom + 1)) + Btom        If InStr(CC, "@" & bb & "@") = 0 Then            aa(I) = bb            CC = CC & "@" & bb & "@"            I = I + 1        End If    Loop Until I = Amount    RandNum = WorksheetFunction.Transpose(aa) End Function

Rất mong được giúp đỡ!
file word đi kèm cho dễ đọc