一応作ってみました。
以下のEnd functionまでの部分を、適当な名前と拡張子vbsで保存してダブルクリックして実行してみて下さい。
'名簿.txtに一行毎入力されている名前を指定された人数で適当なチームに分ける
'同じ名前の人間はいないとする。(でないと区別できないから)
Dim fso, tso
Dim nameList
Dim Filename, Team
Dim all
Dim i, j, member
Filename="名簿.txt" '読み込みファイル名の設定
Team=2 '1チーム何人か?ダブルスの場合2
Set nameList = CreateObject("Scripting.Dictionary")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set tso = fso.OpenTextFile(Filename,1)
i=0
Do until tso.AtEndOfStream
nameList.Add i, tso.ReadLine 'リストに1人読み込む
i=i+1
Loop
tso.Close
all=i '人数が何人いるかを取っておく
Filename="チーム.txt" '書き出しファイル名
Set tso = fso.OpenTextFile(Filename, 2, true)
Randomize
i=1
do until nameList.count < Team
member=""
for j=1 to Team
member = member & selectName() & ","
next
member = left(member,len(member)-1) '最後の,を取り除く
tso.WriteLine("チーム" & CStr(i) & ":" & member)
i=i+1
loop
tso.Close
function selectName()
dim x
do
x=Int(all * Rnd)
Loop until nameList.Exists(x)
selectName=nameList.Item(x)
nameList.Remove(x)
end function
サンプル
名簿.txt
A
B
C
D
E
F
G
H
I
実際は、姓名、余った人はとりあえずは、チーム分けされません。
実行すると作成されるテキストファイル
チーム.txt
チーム1:I,B
チーム2:A,H
チーム3:C,F
チーム4:D,E
お礼
BLUEPIXYさん、返信の方遅れて大変申し訳ありませんでした。 今、実行してみたところ出来ました^^ やはり過去に組んだ人とペアになってしまわないようにするには難しいんですね。でも、そこらへんは何とかカバーして頑張ろうと思います。 これから、チーム分けするのが大分楽になりそうです。本当にありがとうございます。