Snasui Excel Forum

Code: Select all

Set gt = Sheets("Sheet2").Range(grpAll.Offset(1, gc - 1), grpAll.Offset(1, gc - 1) _
    .End(xlDown)).Resize(, 1)

Code: Select all

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
Dim prjs As Range, prj As Range, pjl As Integer
    Dim pa As Range, paCheck As Range, pck As Range
    Dim cmAll As Range, cm As Range, cmr As Range, c As Range
    Dim grpAll As Range, gSl() As Variant, gc As Long
    Dim gt As Range, g As Range, iCount As Integer, i As Integer
    Dim ig As Integer, t As String, x As String
    With Sheets("เชี่ยวชาญ")
        Set grpAll = .Range("D38", .Range("D38").End(xlToRight))
    End With
    With Sheets("Sheet2")
        Set pa = .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
    End With
    With Sheets("ตารางสอบ")
        Set paCheck = .Range("B13", .Range("B" & .Rows.Count).End(xlUp))
    End With
    For Each pck In paCheck

        If pck <> "" Then
        pjl = Application.Match(pck, pa, 0)
        Set cmAll = pa.Offset(pjl - 1, 1).Resize(1, 2)
        gc = Application.Match(pck.Offset(0, 1), grpAll, 0)
        Set gt = Sheets("เชี่ยวชาญ").Range(grpAll.Offset(1, gc - 1), grpAll.Offset(1, gc - 1) _
    .End(xlDown)).Resize(, 1)
        iCount = 0
        For Each g In gt
            If Application.CountIf(cmAll, g) = 0 Then
                ReDim Preserve gSl(iCount)
                gSl(iCount) = g
                iCount = iCount + 1
            End If
        Next g
        Set cmr = pck.Offset(0, 2).Resize(1, 2)
        t = "-"
        i = 0
        For Each c In cmr
            Do While i <= 1
                x = gSl(Int(Rnd * (UBound(gSl) + 1)))
                If InStr(t, x) = 0 Then
                    t = t & x
                    c.Offset(0, i) = x
                    i = i + 1
                End If
            Loop
        Next c
        End If
    Next pck
ErrorHandler:
Application.ScreenUpdating = True
End Sub

Code: Select all

'Other code

With Sheets("เชี่ยวชาญ")
    Set grpAll = .Range("D4", .Range("D4").End(xlToRight))
End With

'Other code

For Each g In gt
    If Application.CountIf(cmAll, g) = 0 And g <> "-" Then
        ReDim Preserve gSl(iCount)
        gSl(iCount) = g
        iCount = iCount + 1
    End If
Next g
Set cmr = pck.Offset(0, 2).Resize(1, 2)
t = "-"
i = 0
For Each c In cmr
    Do While i < iCount And i <= 1
        x = gSl(Int(Rnd * (UBound(gSl) + 1)))
        If InStr(t, x) = 0 Then
            t = t & x
            c.Offset(0, i) = x
            i = i + 1
        End If
    Loop
Next c

'Other code

Code: Select all

gc = Application.Match(pck.Offset(0, 1), grpAll, 0)