均等に振り分ける方法を教えていただけないでしょうか。

いくつもある項目を均等に振り分けたいと思っているんですが、ランダムなどの情報はいくつか目にしたのですが、順に振り分ける方法を探すことができませんでした。

1000近い項目があります。
その項目をひとつのグループが30行ずつに振り分けたいと考えています。
上の行からから２件ずつ（２行ずつA~Ｅ）を抽出。
例）1000÷30＝33.33…　
33枚は最低30行グループが可能
２行ずつ振り分けるため、1～66行がそれぞれの最初の段にくる
67～132行がその次にくる
つまり、一つ目のグループには「メインデータ」の
1.2.67.68.133.134.199.200.265.266.331.332.397.398.463.464.529.530.595.596.661.662.727.728.793.794.859.860.925.926の行が振り分けられる

30で全部が割り切れないと思いますので、グループが増えても、数個のグループが26～29行になるようにしてバランスをとれるのがベストです。

30年以上前に、友人がエクセルで作ってくれたものがあるのですが、私には扱えなくて、スプレッドシートで使用できるものを必要としています。

振り分け後の30行ずつのグループは、「メインデータ」のシートはそのままで、別のシートに作成できるようにしたいです。
また、振り分け前の「メインデータ」には、リンクが挿入されているため、振り分け後の30行ずつのデータにも、リンク情報がコピーされるようにしたいです。

友人が以前に作ってくれたエクセルのコードを、サンプルとして添付します。

どなたか、良い情報を教えていだだけないでしょうか。
よろしくお願いいたします。

Sub pro1()
    Dim 全行番号
    Dim iデータカウント
    Dim 全データ(1 To 100000, 1 To 7)
    Dim Aデータ(1 To 10000, 1 To 7)
    Dim Bデータ(1 To 5000, 1 To 7)
    Dim Zデータ(1 To 100, 1 To 7)
    Dim head1(10), head2(11), 横1行分(10)
    Dim 行数, Z件数, B行数, A行数 As Integer
    Dim ページ行数 As Integer
    Dim A数 As Integer
    Dim 名
    Dim 開始番号 As Integer
    Dim 番号 As Integer
  
    'NEW 2007.02.07
    Dim i全作成 As Integer
    Dim i開始行 As Integer
    Dim i開始部分作成 As Integer
    Dim i最大番号 As Integer
    Dim b部分作成でもヘッダー作成
    
  
  
    '設定取得
    Sheets("設定").Select
    
    チーム名 = Cells(4, 2)        'チーム名
    開始番号 = Cells(5, 2)  '開始する番号
    A数 = Cells(8, 2)  '1つのA数
    ページ行数 = Cells(6, 2)  '1つのA数
    
    i全作成 = (Range("B7").Value)
    
    If i全作成 = 1 Then
        i開始行 = 1
        i開始部分作成 = 開始番号
        
    Else
    
        i開始行 = Range("B15")
        i開始部分作成 = Range("B16")
        i最大番号 = Range("B17")
        
        i_ret = MsgBox("部分作成が選択されています。既存のデータが上書きされる可能性がありますが、よろしいですか？", vbOKCancel + vbInformation, "チーム作成")
        If i_ret = vbCancel Then
            Exit Sub
        End If
        
        
    End If
    
    
    
    'データの取り込み
    チームデータ = チーム
名 + "データ"
    Sheets(区域データ).Select
    全行番号 = 0
    iデータカウント = 0
    
    While Cells(全行番号 + 1 + 3, 1) <> "END"
        
        Dim bGetThis As Boolean 'この行を取得するか 2007.02.07
        
        '今回作成フラグが１のものだけ印刷
        
        If i全作成 = 1 Then
            If Cells(全行番号 + 3, 9).Value = 1 Then
                bGetThis = True
            Else
                bGetThis = False
            End If
        ElseIf i全作成 = 2 Then
            If Cells(全行番号 + 3, 9).Value = 1 Then
                bGetThis = True
            Else
                bGetThis = False
            End If
        End If
        
        全行番号 = 全行番号 + 1
        
        If bGetThis Then
            iデータカウント = iデータカウント + 1
            
            全データ(iデータカウント, 1) = Cells(全行番号 + 3, 1)
            全データ(iデータカウント, 2) = Cells(全行番号 + 3, 2)
            全データ(iデータカウント, 3) = Cells(全行番号 + 3, 3)
            全データ(iデータカウント, 4) = Cells(全行番号 + 3, 4)
            全データ(iデータカウント, 5) = Cells(全行番号 + 3, 5)
            全データ(iデータカウント, 6) = Cells(全行番号 + 3, 6)
            全データ(iデータカウント, 7) = Cells(全行番号 + 3, 7)
            End If
    Wend
    
    'データの振分け（AチームとBチーム、Zに分ける）
    A数 = 0
    B数 = 0
    Z数 = 0
    For Index = 1 To iデータカウント
    
        '対象外の抽出
        If 全データ(Index, 7) <> "" Then
            対象外行数 = 対象外行数 + 1
            対象外データ(対象外行数, 2) = 全データ(Index, 2)
            対象外データ(対象外行数, 3) = 全データ(Index, 3)
            対象外データ(対象外行数, 4) = 全データ(Index, 4)
            対象外データ(対象外行数, 5) = 全データ(Index, 5)
            対象外データ(対象外行数, 6) = 全データ(Index, 6)
            対象外データ(対象外行数, 7) = 全データ(Index, 7)
                  
            Else
                'Aの抽出
                A数 = A数 + 1
                Aデータ(A数, 2) = 全データ(Index, 2)
                Aデータ(A数, 3) = 全データ(Index, 3)
                Aデータ(A数, 4) = 全データ(Index, 4)
                Aデータ(A数, 5) = 全データ(Index, 5)
                Aデータ(A数, 6) = 全データ(Index, 6)
            End If
        End If
    Next Index
  
    'Aの作成
    Sheets("ヘッダー").Select
    head1(0) = Cells(1, 1)
    head1(1) = チーム名
    head1(2) = Cells(1, 3)
    head1(3) = Cells(1, 4)
    head1(4) = Cells(1, 5)
    head1(5) = Cells(1, 6)
    head1(6) = Cells(1, 7)
    head1(7) = Cells(1, 8)
    head1(8) = Cells(1, 9)
    head1(9) = Cells(1, 10)
    
    チーム名班 = チーム名 + "班"
    Sheets(チーム名班).Select
    
    '全作成のときは、データを消去する
    If i全作成 = 1 Then
        Cells.Select
        Selection.ClearContents
    Else
        
        i_ret = MsgBox("部分作成が選択されています。以前のデータを消す場合は「はい」" & vbCrLf & "、消さない場合は「いいえ」を押してください", vbYesNo + vbInformation, "チーム作成")
        If i_ret = vbYes Then
            Cells.Select
            Selection.ClearContents
            b部分作成でもヘッダー作成 = True
        Else
            b部分作成でもヘッダー作成 = False
        End If
        
    End If
    
    
    
    '最初に始める場所を計算する
    番号 = i開始行
    行番号 = i開始行 + (i開始部分作成 - 開始番号) * ページ行数
    ヘッダー行 = 2 + (i開始部分作成 - 開始番号) * 2      'ヘッダー分の行数
  
    '全区域数の計算
    
    '全作成のときは、件数を計算する
    If i全作成 = 1 Then
        
        If (A行数 / A数) = 0 Then
            チーム数 = A行数 / A数
        Else
            If (A数 Mod A数) < (A数 / 2) Then
                チーム数 = CInt(A数 / A数) + 1
            Else
                チーム数 = CInt(A数 / A数)
            End If
        End If
    Else
    '部分作成のときは、最大番号を取得する
        チーム数 = i最大番号 - 開始チーム番号 + 1
    End If
    
  
  
    For Index = 1 To A数
        横1行分(0) = 番号
        横1行分(1) = Aデータ(Index, 2)
        横1行分(2) = Aデータ(Index, 3)
        横1行分(3) = Aデータ(Index, 4)
        横1行分(4) = Aデータ(Index, 5)
        横1行分(5) = Aデータ(Index, 6)
        
        
        Range(Cells(行番号 + ヘッダー行, 1), Cells(行番号 + ヘッダー行, 10)) = 横1行分
        Range(Cells(行番号 + ヘッダー行, 1), Cells(行番号 + ヘッダー行, 10)).Font.Bold = False
        Range(Cells(行番号 + ヘッダー行, 1), Cells(行番号 + ヘッダー行, 10)).Font.Italic = False
        
        番号 = 番号 + 1
        
        行番号 = 行番号 + 1
        
        Index = Index + 1
        
        横1行分(0) = 番号
        横1行分(1) = Aデータ(Index, 2)
        横1行分(2) = Aデータ(Index, 3)
        横1行分(3) = Aデータ(Index, 4)
        横1行分(4) = Aデータ(Index, 5)
        横1行分(5) = Aデータ(Index, 6)
        
        
        Range(Cells(行番号 + ヘッダー行, 1), Cells(行番号 + ヘッダー行, 10)) = 横1行分
        Range(Cells(行番号 + ヘッダー行, 1), Cells(行番号 + ヘッダー行, 10)).Font.Bold = False
        Range(Cells(行番号 + ヘッダー行, 1), Cells(行番号 + ヘッダー行, 10)).Font.Italic = False
        
        行番号 = 行番号 - 1
        
        番号 = 番号 - 1
                
        行番号 = 行番号 + ページ行数
        '    行番号 = 行番号 + A数
        ヘッダー行 = ヘッダー行 + 2
        
        
        '    If 行番号 > チーム数 * A数 Then
        If 行番号 > チーム数 * ページ行数 Then
            番号 = 番号 + 2
            行番号 = 番号
            ヘッダー行 = 2
        End If
    Next Index
  
    '全作成のときは、ヘッダーを作成する
    If i全作成 = 1 Or b部分作成でもヘッダー作成 Then
        'Aのヘッダー
        行番号 = 2
        For Index = 開始番号 To 開始番号 + 数 - 1
            head1(0) = Index
            Range(Cells(行番号, 1), Cells(行番号, 10)) = head1
            Range(Cells(行番号, 1), Cells(行番号, 10)).Font.Bold = True
            Range(Cells(行番号, 1), Cells(行番号, 10)).Font.Italic = True
            '    行番号 = 行番号 + A数 + 2
            行番号 = 行番号 + ページ行数 + 2
        Next Index
    End If
 
    '後処理
    Sheets("設定").Select
    
    Range("B20").Value = A行数
    Range("B21").Value = チーム数
    Range("B22").Value = 開始番号 + 数 - 1
    
    Call MsgBox("処理が無事に終了しました", vbOKOnly, "チーム")
 
End Sub

コード

行動規範の内容に同意します

回答1件

ベストアンサー

質問からずいぶん日数が経過していますが、当初の質問に削除要請がなされてしまって回答できずにいたのですが、
今ほど、この質問を見つけたので、当時作成していた回答を今更ながらアップしてみます。
シート1のデータに基づき、チームごとのシートを作成してデータを割り振ります。

JavaScript
1function divideTeams() {
2  const numMember = 30;//←チームの人数を指定
3  const sheetName = 'シート1';//元データのシート名を指定
4  const rowBegin = 2;//←データの開始行を指定
5  const columnUrl = 'F';//←URLの列を指定
6  const ss = SpreadsheetApp.getActiveSpreadsheet();
7  const sheet = ss.getSheetByName(sheetName);
8  const values = sheet.getDataRange().getValues();
9  const title = rowBegin > 1 ? values.splice(0, rowBegin - 1) : false;
10  //シートのデータを取得してチームに振分け
11  const numData = values.length;
12  const numTeam = Math.ceil(numData / numMember);
13  const teams = [];
14  let ix = 0;
15  for (let i = 0; i < numTeam; i++) {
16    const temp = values.filter((v, index) => index % (numTeam * 2) == 0 + ix || index % (numTeam * 2) == 1 + ix);
17    teams.push(temp);
18    ix = ix + 2;
19  }
20  //振り分けたチームごとにシート（無いなら作成）にデータを挿入
21  if (teams.length > 0) {
22    const sheets = ss.getSheets();
23    for (i = 0; i < numTeam; i++) {
24      const name = 'チーム' + (i + 1);
25      //シートが無いなら作成
26      let isMach = false;
27      for (const iSheet of sheets) {
28        if (iSheet.getName() == name) {
29          isMach = true;
30          break;
31        }
32      }
33      if (!isMach) {
34        ss.insertSheet(name);
35      }
36      //シートに挿入
37      const newSheet = ss.getSheetByName(name);
38      newSheet.clear();
39      if (title) {
40        newSheet.getRange(1, 1, title.length, title[0].length).setValues(title);
41      }
42      newSheet.getRange(newSheet.getLastRow() + 1, 1, teams[i].length, teams[i][0].length)
43        .setValues(teams[i]);
44      newSheet.getRange(columnUrl + ':' + columnUrl).setNumberFormat('General');//念のため
45    }
46  }
47}