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
