
ตัวอย่าง Code ตามด้านล่างครับ
Code: Select all
Sub test()
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 Integer
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("Sheet2")
Set pa = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
Set grpAll = .Range("f1", .Range("f1").End(xlToRight))
End With
With Sheets("Sheet3")
Set paCheck = .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
End With
For Each pck In paCheck
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 = 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
Next pck
End Sub