excelで入力されているセルを飛ばして自動で振り分けをしたい。 お世話になります。 Sheet2に下記のような作業毎のグループ分けした表があります。
excelで入力されているセルを飛ばして自動で振り分けをしたい。 お世話になります。 Sheet2に下記のような作業毎のグループ分けした表があります。 作業AであればABCD氏が作業可能と分かる表です。 それをSheet1の表の同じ作業項目の下のセルに作業者をVBAで振り分けしています。 重複する場合は下記の人へ移り、該当者がいない場合は空白といった感じです。 これを既にSheet1の振り分け予定のセルに入力されている所は飛ばして振り分けは出来ないでしょうか？ お知恵をお貸し下さい。 (Sheet2の表) 作業A|作業Ｂ|作業C|作業E A氏 |A氏 |D氏 |D氏 B氏 |B氏 |E氏 |E氏 C氏 |C氏 |F氏 |G氏 D氏 | (Sheet1の表(都度変更あり)) ①|作業A|作業Ｂ|作業C|作業E -------------------------------- ①| -------------------------------- ②|作業A|作業Ｂ -------------------------------- ②| -------------------------------- ③|作業Ｂ|作業C -------------------------------- ③| -------------------------------- (振り分け後の表) ①|作業A|作業Ｂ|作業C -------------------------------- ①|A氏 |B氏 |D氏 -------------------------------- ②|作業A|作業Ｂ -------------------------------- ②|C氏 |空白 -------------------------------- ③作業Ｂ|作業C -------------------------------- ③空白 |E氏 -------------------------------- 現在のコード Private Sub CommandButton1_Click() Dim ws As Worksheet, rStaffRange As Range, iStaffRow As Long, iStaffColumn As Variant Set ws = Worksheets("sheet2") Set rStaffRange = ws.Range(ws.Range("A1"), ws.Range("A1").End(xlToRight)) Dim sAssign As String, ii As Long, jj As Long sAssign = "" On Error Resume Next For ii = Range("A1").Row To Cells(Rows.CountLarge, "A").End(xlUp).Row Step 3 For jj = 1 To Cells(ii, Columns.CountLarge).End(xlToLeft).Column iStaffColumn = WorksheetFunction.Match(Cells(ii, jj).Value, rStaffRange, 0) If (Not iStaffColumn Is Nothing) Then For iStaffRow = rStaffRange.Offset(1).Row To ws.Cells(ws.Rows.CountLarge, iStaffColumn).End(xlUp).Row If (InStr(sAssign, ws.Cells(iStaffRow, iStaffColumn).Value) = 0) Then Cells(ii + 1, jj).Value = ws.Cells(iStaffRow, iStaffColumn).Value sAssign = sAssign & "◆" & ws.Cells(iStaffRow, iStaffColumn).Value Exit For End If Next iStaffRow End If Next jj Next ii On Error GoTo 0 Set ws = Nothing Set rStaffRange = Nothing End Sub
Excel | Visual Basic・88閲覧・250
ベストアンサー
一日分なのですかね？理解不足の場合は、ごめんなさい。 セル数は多いのですかね？メモリ不足の場合も、ごめんなさい。 Private Sub CommandButton1_Click() Dim ws As Worksheet, staffpool As Variant Dim ii As Long, jj As Long ''「sheet2」表をロードする。 Set ws = Worksheets("sheet2") With ws.Range("A1").CurrentRegion staffpool = ws.Range("A1").Resize(.Rows.CountLarge, .Columns.CountLarge) End With ''「作業行」における「作業列」に担当者を割り当てる。 ''但し、「担当者」が割り当てられいないセルとする。 For ii = 1 To Cells(Rows.CountLarge, "A").End(xlUp).Row Step 2 For jj = 1 To Cells(ii, Columns.CountLarge).End(xlToLeft).Column If (Cells(ii + 1, jj).Value = "") Then Cells(ii + 1, jj).Value = FunAssign(Cells(ii, jj), staffpool) End If Next jj Next ii End Sub Private Function FunAssign(ByVal rWorkName As Range, ByRef staffpool As Variant) As String Dim ii As Long, jj As Long, mm As Long, nn As Long ''一旦、「担当者」なしを設定する。 FunAssign = "" ''「作業」（列）を列求める。 For jj = 1 To UBound(staffpool, 2) If (rWorkName.Value = staffpool(1, jj)) Then ''「担当者」（空白以外）を設定する。 For ii = 2 To UBound(staffpool, 1) If (staffpool(ii, jj) <> "") Then FunAssign = staffpool(ii, jj) ''対象者をスタックからクリアする。 For nn = 1 To UBound(staffpool, 2) For mm = 2 To UBound(staffpool, 1) If (staffpool(mm, nn) = FunAssign) Then staffpool(mm, nn) = "" End If Next mm Next nn Exit Function End If Next ii End If Next jj End Function
takさんありがとうございます。 処理したいのは1日分です。 sheet2のデータは多いですが、sheet1は1行10作業程度×5です。 早速試してみましたところ希望通りの結果になりました。 凄く感激しました。ありがとうございます。 一点相談させてもらいたいのですが、例えばA氏を既に入力しておいてvbaを動かすと、またA氏が出てきてしまうのですが、作業者を重複しないようには出来ませんでしょうか？ 無理ばかりで申し訳ありませんが宜しくお願い致します。
質問者からのお礼コメント
takさんありがとうございます。 完璧です。 感銘を受けました。 希望通りの動きです、こんなこと出来てしまうんですね。 本当にありがとうございました。 これで作業が楽になります。
お礼日時：5/21 16:49
