マクロについてです。 ・上図のシート名は7月です。4~12月のシートがあります。行が月日です。 ・下図のシート名は 名簿 です。人数は400人ほどです。

画像

Visual Basic | Excel76閲覧xmlns="http://www.w3.org/2000/svg">50

ベストアンサー

0

ThanksImg質問者からのお礼コメント

ありがとうございました!

お礼日時:9/16 20:06

その他の回答(1件)

1

実行結果は添付画像のとおりです。 よろしければご利用ください。 変更内容 ・列数の制限を外しました。Y列以上でも利用できます。 ・同じ人が同じ日に複数の学校に行くことになった場合は名簿シート、各月シートともに該当セルが赤くなるようにしました。 ・番号が名簿シートに定義されていない場合、ダイアログ表示で定義を促すようにしています。 --- Sub 名簿に反映() Application.ScreenUpdating = False Dim studentNumberRng As Range ' 既存の名簿シートデータ削除 Dim sh1 As Worksheet Set sh1 = Worksheets("名簿") With sh1 Dim rmax As Long Dim cmax As Long With .Range("A1").CurrentRegion rmax = .Row + .Rows.Count - 1 End With With .Range("A1").CurrentRegion cmax = .Column + .Columns.Count - 1 End With .Range(.Cells(2, 5), .Cells(rmax, cmax)).ClearContents Set studentNumberRng = .Range("A1:A" & rmax) End With Dim i As Integer Dim j As Integer Dim notDefinedDict As Object Set notDefinedDict = CreateObject("Scripting.Dictionary") ' 1 ~ 12月を処理 For i = 1 To 12 ' 4月 ~ 3月の処理順にする If i < 10 Then j = i + 3 Else j = i - 9 End If ' 該当月のシートがなければ、その月のシートは処理しない On Error Resume Next Dim sh2 As Worksheet Set sh2 = Nothing Set sh2 = Worksheets(j & "月") If Not sh2 Is Nothing Then With sh2 Dim sh1Dict As Object Dim sh2Dict As Object Dim key As Variant Dim sh1WorkingRng As Range Dim sh2WorkingRng As Range Dim r As Long Dim c As Long Dim sh1MatchRow As Variant Dim sh1WorkingColumn As Long Set sh1Dict = CreateObject("Scripting.Dictionary") Set sh2Dict = CreateObject("Scripting.Dictionary") For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row For c = 2 To .Cells(1, Columns.Count).End(xlToLeft).Column - 2 Step 3 If .Cells(r, c).Value <> "" Then sh1MatchRow = Application.Match(.Cells(r, c + 1).Value, studentNumberRng, 0) If IsError(sh1MatchRow) = False Then sh1WorkingColumn = sh1.Cells(sh1MatchRow, Columns.Count).End(xlToLeft).Column + 1 key = .Cells(r, 1).Value & .Cells(r, c + 2).Value Set sh1WorkingRng = sh1.Range(sh1.Cells(sh1MatchRow, sh1WorkingColumn), sh1.Cells(sh1MatchRow, sh1WorkingColumn + 1)) Set sh2WorkingRng = .Range(.Cells(r, c), .Cells(r, c + 2)) If (sh1Dict.Exists(key)) Then Set sh1Dict(key) = Union(sh1Dict(key), sh1WorkingRng) Set sh2Dict(key) = Union(sh2Dict(key), sh2WorkingRng) sh1Dict(key).Interior.Color = RGB(255, 0, 0) sh2Dict(key).Interior.Color = RGB(255, 0, 0) Else sh1Dict.Add key, sh1WorkingRng sh2Dict.Add key, sh2WorkingRng End If sh1.Cells(sh1MatchRow, sh1WorkingColumn).Value = .Cells(r, 1).Value sh1.Cells(sh1MatchRow, sh1WorkingColumn + 1).Value = .Cells(r, c).Value Else ' 各月の番号が名簿シートに定義されていない場合、リストに追加する If (Not (notDefinedDict.Exists(.Cells(r, c + 1).Value))) Then notDefinedDict.Add .Cells(r, c + 1).Value, 1 End If End If End If Next c Next r sh1Dict = Nothing sh2Dict = Nothing End With End If Next i ' 未定義の番号をダイアログで表示する If (notDefinedDict.Count > 0) Then MsgBox "番号「" & Join(notDefinedDict.keys, ", ") & "」が" & sh1.Name & "シートで未定義です。" & vbCrLf _ & "未定義の場合は" & sh1.Name & "シートに転記されませんので、" & vbCrLf _ & sh1.Name & "シートに定義後、再実行してください。" _ , vbCritical End If Application.ScreenUpdating = True End Sub

画像

1人がナイス!しています