Xếp sơ đồ chổ ngồi của học sinh (1 người xem)

[0167767]

Chào các bạn mình có xem 1 số bài tập trên diễn đàn GPE nhưng chưa đúng ý tưởng của mình. Nên muốn các bạn giúp đỡ. Xếp sơ đồ chổ ngồi cho học sinh trường mình. Các bạn xem file giúp mình nhe.
- Một phòng học có 4 dãy bàn. Số học sinh trong lớp nhiều nhất là 48 em. Ít nhất là 30 em.
- Vậy trong phong học từ 30 đến 48 học sinh. Sĩ số lớp có thể thay đổi số học sinh từ 30 đến 48 em, ở sheetDSHS.
Sắp xếp chổ ngồi sao cho: H/s Giỏi và Khá ngồi chung với học sinh TB hoặc yếu.
Mình đã qui đinh.
Giỏi là 1.
Khá là 2.
TB là 3.
Yếu là 4.
Rất mong các bạn GPE giúp đỡ mình thành thật cảm ơn rất nhiều.

 

[HungQuoc49]

Chào các bạn mình có xem 1 số bài tập trên diễn đàn GPE nhưng chưa đúng ý tưởng của mình. Nên muốn các bạn giúp đỡ. Xếp sơ đồ chổ ngồi cho học sinh trường mình. Các bạn xem file giúp mình nhe.
- Một phòng học có 4 dãy bàn. Số học sinh trong lớp nhiều nhất là 48 em. Ít nhất là 30 em.
- Vậy trong phong học từ 30 đến 48 học sinh. Sĩ số lớp có thể thay đổi số học sinh từ 30 đến 48 em, ở sheetDSHS.
Sắp xếp chổ ngồi sao cho: H/s Giỏi và Khá ngồi chung với học sinh TB hoặc yếu.
Mình đã qui đinh.
Giỏi là 1.
Khá là 2.
TB là 3.
Yếu là 4.
Rất mong các bạn GPE giúp đỡ mình thành thật cảm ơn rất nhiều.

Có tính tới trường hợp TB + yếu > Giỏi + Khá không bạn
---

Public Sub Xep_Kem_Gioi()
'Neu Kem>Gioi thi uu tien xep hoc sinh kem len hang dau
Dim Nguon, Km, Gi, Tam
Dim SLNgang, SLDoc, Kq()
Dim r As Long, c As Long

SLNgang = 8 * 2 - 1
SLDoc = 6 * 2 - 1
ReDim Kq(1 To SLDoc, 1 To SLNgang)
Nguon = Sheet1.Range("A9", Sheet1.Range("D65000").End(xlUp))

If UBound(Nguon) > ((SLNgang + 1) / 2) * ((SLDoc + 1) / 2) Then
MsgBox "Thieu Ban"
Exit Sub
End If

With CreateObject("Scripting.Dictionary")
Randomize
For c = 1 To UBound(Nguon) * (UBound(Nguon) - 1) / 2
Tam = Int(Rnd * UBound(Nguon) + 1)
If .exists(Tam) = False Then
.Add Tam, ""
If Nguon(Tam, 4) > 2 Then
Km = Km & IIf(Km = "", "", "#") & Nguon(Tam, 2) & "_" & Nguon(Tam, 4)
Else
Gi = Gi & IIf(Gi = "", "", "#") & Nguon(Tam, 2) & "_" & Nguon(Tam, 4)
End If
End If
If .Count = ((SLNgang + 1) / 2) * ((SLDoc + 1) / 2) Then Exit For
Next c
Km = Split(Km, "#")
Gi = Split(Gi, "#")
End With

If UBound(Km) > UBound(Gi) Then
Tam = String(UBound(Km) - UBound(Gi), "#")
Gi = Split(Tam & Join(Gi, "#"), "#")
End If

If UBound(Km) < UBound(Gi) Then
Tam = String(UBound(Gi) - UBound(Km), "#")
Km = Split(Join(Km, "#") & Tam, "#")
End If

For c = 0 To UBound(Km)
Kq((c \ (SLNgang / 4)) * 2 + 1, (c Mod (SLNgang / 4)) * 3 + 1) = Km(c)
Kq((c \ (SLNgang / 4)) * 2 + 1, (c Mod (SLNgang / 4)) * 3 + 2) = Gi(c)
Next c

With Sheet2
.Range("A10:K20").CurrentRegion.ClearContents
.Range("A10").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
.Range("A10").Resize(UBound(Kq), UBound(Kq, 2)).Columns.AutoFit
End With
End Sub

 

[HieuCD]

Xếp chổ không theo thứ tự danh sách

Sub XepCho()
Dim Dic As Object, Darr, Arr()
Dim i, i, g, y, k, Sban As Integer
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DSHS")
    Darr = .Range("A9:D" & .Range("A9").End(xlDown).Row)
End With
ReDim Arr(1 To 24, 1 To 2)
On Error Resume Next
Do Until y + g = UBound(Darr)
    tmp = Int(UBound(Darr) * Rnd + 1)
    If Not Dic.exists(tmp) Then
        Dic.Add tmp, ""
        If Darr(tmp, 4) < 3 Then
            g = g + 1: Arr(g, 1) = Darr(tmp, 2)
        Else
            y = y + 1: Arr(y, 2) = Darr(tmp, 2)
        End If
    End If
Loop
Set Dic = Nothing
Sban = Int((UBound(Darr) + 1) / 2)
If g - y > 1 Then
    For i = y + 1 To Sban
        Arr(i, 2) = Arr(g - (i - y - 1), 1)
        Arr(g - (i - y - 1), 1) = ""
    Next
End If
If y - g > 1 Then
    For i = g + 1 To Sban
        Arr(i, 1) = Arr(y - (i - g - 1), 2)
        Arr(y - (i - g - 1), 2) = ""
    Next
End If
With Sheets("SODO")
    .Range("A10:O20").ClearContents
    For i = 1 To 12 Step 2
        For J = 1 To 13 Step 4
            k = k + 1
            .Cells(i + 9, J) = Arr(k, 1)
            .Cells(i + 9, J + 2) = Arr(k, 2)
        Next
    Next
End With
End Sub

 

[0167767]

Bạn xem lại dùm mình code chưa chạy được vậy bạn. Cảm ơn bạn

 

[HieuCD]

Bạn xem lại dùm mình code chưa chạy được vậy bạn. Cảm ơn bạn

bạn phải nói rỏ code của bạn nào? và không chạy được như thế nào?

 

[0167767]

Xếp chổ không theo thứ tự danh sách

Sub XepCho()
Dim Dic As Object, Darr, Arr()
Dim i, i, g, y, k, Sban As Integer
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DSHS")
    Darr = .Range("A9:D" & .Range("A9").End(xlDown).Row)
End With
ReDim Arr(1 To 24, 1 To 2)
On Error Resume Next
Do Until y + g = UBound(Darr)
    tmp = Int(UBound(Darr) * Rnd + 1)
    If Not Dic.exists(tmp) Then
        Dic.Add tmp, ""
        If Darr(tmp, 4) < 3 Then
            g = g + 1: Arr(g, 1) = Darr(tmp, 2)
        Else
            y = y + 1: Arr(y, 2) = Darr(tmp, 2)
        End If
    End If
Loop
Set Dic = Nothing
Sban = Int((UBound(Darr) + 1) / 2)
If g - y > 1 Then
    For i = y + 1 To Sban
        Arr(i, 2) = Arr(g - (i - y - 1), 1)
        Arr(g - (i - y - 1), 1) = ""
    Next
End If
If y - g > 1 Then
    For i = g + 1 To Sban
        Arr(i, 1) = Arr(y - (i - g - 1), 2)
        Arr(y - (i - g - 1), 2) = ""
    Next
End If
With Sheets("SODO")
    .Range("A10:O20").ClearContents
    For i = 1 To 12 Step 2
        For J = 1 To 13 Step 4
            k = k + 1
            .Cells(i + 9, J) = Arr(k, 1)
            .Cells(i + 9, J + 2) = Arr(k, 2)
        Next
    Next
End With
End Sub

cảm ơn bạn. Code báo lỗi như hình bạn xem giúp mình nhé.

 

[HieuCD]

View attachment 165296
cảm ơn bạn. Code báo lỗi như hình bạn xem giúp mình nhé.

không biết tại sao bị lổi không thể có nầy!!!
bạn dùng code mới, thêm số thứ tự cho dể nhìn

Dim Dic As Object, Darr, Arr()
Dim i, g, y, k, Sban As Integer
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DSHS")
    Darr = .Range("A9:D" & .Range("A9").End(xlDown).Row)
End With
ReDim Arr(1 To 24, 1 To 2)
On Error Resume Next
Do Until y + g = UBound(Darr)
    tmp = Int(UBound(Darr) * Rnd + 1)
    If Not Dic.exists(tmp) Then
        Dic.Add tmp, ""
        If Darr(tmp, 4) < 3 Then
            g = g + 1: Arr(g, 1) = Darr(tmp, 1) & ". " & Darr(tmp, 2)
        Else
            y = y + 1: Arr(y, 2) = Darr(tmp, 1) & ". " & Darr(tmp, 2)
        End If
    End If
Loop
Set Dic = Nothing
Sban = Int((UBound(Darr) + 1) / 2)
If g - y > 1 Then
    For i = y + 1 To Sban
        Arr(i, 2) = Arr(g - (i - y - 1), 1)
        Arr(g - (i - y - 1), 1) = ""
    Next
End If
If y - g > 1 Then
    For i = g + 1 To Sban
        Arr(i, 1) = Arr(y - (i - g - 1), 2)
        Arr(y - (i - g - 1), 2) = ""
    Next
End If
With Sheets("SODO")
    .Range("A10:O20").ClearContents
    For i = 1 To 12 Step 2
        For J = 1 To 13 Step 4
            k = k + 1
            .Cells(i + 9, J) = Arr(k, 1)
            .Cells(i + 9, J + 2) = Arr(k, 2)
        Next
    Next
End With
Application.ScreenUpdating = True
End Sub

 

[HieuCD]

bạn nhận file chạy thử xem sao

 

[thanvtt]

Xin làm phiền bạn tí nhé! mình muốn chỉnh lại code hiện thị thành 3 dãy (3 cột) và 7 hàng.