Excelシート１内容をシート２に記号入力

質問

Excelシート１の氏名、日付入力後、コマンドボタン入力をクリックしたらシート２に氏名と日付がマッチしたところにA班は○印をB班は△印マーキングしたいのですがコードがどなたか解る方よろしくお願いします。

回答No.1

tom04 · ベストアンサー

こんにちは！
一例です。

画像ではSheet1にコマンドボタンを配置されているようですが
一旦↓のコードを標準モジュールにコピー＆ペーストしてみてください。

Sub Sample1() 'この行から
Dim i As Long, j As Long, k As Long, c As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
i = wS2.Cells(Rows.Count, 1).End(xlUp).Row
j = wS2.Cells(1, Columns.Count).End(xlToLeft).Column
Range(wS2.Cells(2, 2), wS2.Cells(i, j)).ClearContents
'A班操作
For i = 2 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
Set c = wS2.Range("A:A").Find(what:=wS1.Cells(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
k = c.Row
For j = 2 To wS2.Cells(1, Columns.Count).End(xlToLeft).Column
If WorksheetFunction.Count(Range(wS1.Cells(i, 2), wS1.Cells(i, 4))) = 2 Then
If wS2.Cells(1, j) >= wS1.Cells(i, 2) And wS2.Cells(1, j) <= wS1.Cells(i, 4) Then
wS2.Cells(k, j) = "○"
End If
Else
If wS2.Cells(1, j) = wS1.Cells(i, 2) Then
wS2.Cells(k, j) = "○"
End If
End If
Next j
End If
Next i
'B班操作
For i = 2 To wS1.Cells(Rows.Count, 5).End(xlUp).Row
Set c = wS2.Range("A:A").Find(what:=wS1.Cells(i, 5), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
k = c.Row
For j = 2 To wS2.Cells(1, Columns.Count).End(xlToLeft).Column
If WorksheetFunction.Count(Range(wS1.Cells(i, 6), wS1.Cells(i, 8))) = 2 Then
If wS2.Cells(1, j) >= wS1.Cells(i, 6) And wS2.Cells(1, j) <= wS1.Cells(i, 8) Then
wS2.Cells(k, j) = "△"
End If
Else
If wS2.Cells(1, j) = wS1.Cells(i, 6) Then
wS2.Cells(k, j) = "△"
End If
End If
Next j
End If
Next i
End Sub 'この行まで

次にコマンドボタンのコードを↓にして、コマンドボタンをクリックしてみてください。

Private Sub CommandButton1_Click()
Call Sample1
End Sub

こんなんではどうでしょうか？m(_ _)m