Countifに基づいて名前を行に均等に配信する

Question

VBAコードを少し書くのに問題があり、完了の方法を探しています。

私のデータセットには、A、B、またはCのようなカテゴリの列が含まれます。行の数は常に変化します。カテゴリを配列に設定したら、ループスルーして別のタブのテーブルに対して値をルックアップしますが、カテゴリがCの場合は、Cを含む行の数を数え、従業員名のリストにこれらの行を均等に分配する必要がありますテーブル内でカテゴリA & Bのルックアップが現在機能しています。両方のデータセット&テーブルでカテゴリCの行を数えることができました。 「CntPerStaff」番号までの行に従業員名を正しく挿入し、次にテーブル内の次の従業員名に移動する方法が不明です。

Dim LastRow As Long, i As Long 
Dim Arr1 As Variant, Arr2 As Variant 

'Finds last row in data set 
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row 

'Set data columns to arrays 
    Arr1 = Range("AP2:AP" & LastRow).Value 'Category 
    Arr2 = Range("AQ2:AQ" & LastRow).Value 'Employee 

    For i = 1 To UBound(Arr1) 

    If Arr1(i, 1) = "A" Then 
     Arr2(i, 1) = Application.WorksheetFunction.VLookup("A", Worksheets("Tables").Range("CATEGORYID"), 2, False) 
    ElseIf Arr1(i, 1) = "B" Then 
     Arr2(i, 1) = Application.WorksheetFunction.VLookup("B", Worksheets("Tables").Range("CATEGORYID"), 2, False) 
    Else 'Need to insert countif functionality 
    End If 
Next i 

'Place employee name array into spreadsheet 
    Range("AQ2").Resize(UBound(Arr2, 1), 1).Value = Arr2 

これは私がCOUNTIFコードに、これまで持っているものです。

Dim Count As Variant, CntPerStaff As Variant, Arr1 As Variant 
Dim LastRow As Long, i As Long, Cnt As Long, Staff As Long, CntStart As Long 

'Finds last row in data set 
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row 
    Cnt = WorksheetFunction.CountIf(Range("AP2:AP" & LastRow), "C") 
    Staff = WorksheetFunction.CountIf(Worksheets("Tables").Range("CATEGORYID"), "C") 
    CntPerStaff = WorksheetFunction.RoundUp(Cnt/Staff, 0) 

Example of Table and Data (red is info which macro will output)

Answer 1

これはまさに私が行っていた効果はありませんが、それは均一な分布を与えるために仕事をします表に記載されている従業員に行を追加します。上記のようにA & Bを決定するコードを使用し、このループを実行する前にその列をソートして、データの最後に空白の行を得ました。

'Set table and copy names 
Set Source = Worksheets("Tables").ListObjects("CATEGORYID")  
    With Source 
     .Range.AutoFilter Field:=1, Criteria1:="C" 
     SourceDataRows = .ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy 
    End With 

'Loop to paste names 
    Do While x < LastRow 
     x = Cells(Rows.Count, "AQ").End(xlUp).Row + 1 
      With Worksheets("Data").Range("AQ" & Rows.Count).End(xlUp).Offset(1) 
       .PasteSpecial Paste:=xlPasteColumnWidths 
       .PasteSpecial Paste:=xlPasteValues 
      End With 
     Loop 

'Remove any names which pasted past the last row of data 
    With ActiveSheet 
     .Range("A" & LastRow + 1 & ":AQ" & .Rows.Count).ClearContents 
    End With