【Excel マクロ入門③】入力したデータを自動で振り分けする

Excelマクロ（VBA）は「業務を自動化できる便利な機能」として知られています。

この記事では、マクロ（VBA）を“理解する”ことを目的に、条件を満たすデータだけを自動で合計する仕組みをシンプルな1つの実例で紹介します。

具体的には

「入力シート（Sheet1）」に 5つの項目（例：番号／日付／名前／プロジェクト名／担当部署） を記入する
「カテゴリ」の内容に応じて、そのカテゴリ名に対応する別シートの表へ自動でデータを追記する
データの追記が処理できた場合とできなかった場合をメッセージにて表示させる

まず「コードの作成」を紹介し、その後「コードがどのように動くか」を順を追って解説しています。

例：

この記事の内容と特徴

ネスト構造（複数の条件）の理解
メッセージ機能の理解
複数シート間のデータ移動の仕組みを理解

VBAコードの作成

「表に入力した内容に対応する各シートの表にその内容を記載する」処理を行うコードを作ります。

コピペ用VBAコード表示

Sub データ更新()
Dim wsInput As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim targetLastRow As Long
Dim i As Long
Dim projectNames() As String
Dim proj As Variant
Dim found As Range
Dim newProjects As String
Dim transferred As Boolean
Set wsInput = Worksheets("Sheet1") ' シート1の最後に入力された行を取得 lastRow = wsInput.Cells(wsInput.Rows.Count, "A").End(xlUp).Row newProjects = "" transferred = False ' 最後の行だけを処理対象 i = lastRow ' プロジェクト列を半角カンマに統一 Dim projStr As String projStr = wsInput.Cells(i, "D").Value projStr = Replace(projStr, "、", ",") ' 全角読点を半角カンマに projStr = Replace(projStr, " ", "") ' 空白削除 projectNames = Split(projStr, ",") For Each proj In projectNames proj = Trim(proj) ' 対応するシートがあるか確認 On Error Resume Next Set wsTarget = Worksheets(proj) On Error GoTo 0 If Not wsTarget Is Nothing Then ' 既存チェック（番号 + プロジェクト） Set found = Nothing Dim r As Long For r = 2 To wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If wsTarget.Cells(r, "A").Value = wsInput.Cells(i, "A").Value And _ wsTarget.Cells(r, "D").Value = proj Then Set found = wsTarget.Cells(r, "A") Exit For End If Next r If found Is Nothing Then ' 転記先シートの最終行に追加 targetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "B").End(xlUp).Row + 1 wsTarget.Cells(targetLastRow, "A").Value = wsInput.Cells(i, "A").Value ' 番号 wsTarget.Cells(targetLastRow, "B").Value = wsInput.Cells(i, "B").Value ' 日付 wsTarget.Cells(targetLastRow, "C").Value = wsInput.Cells(i, "C").Value ' 名前 wsTarget.Cells(targetLastRow, "D").Value = proj ' プロジェクト wsTarget.Cells(targetLastRow, "E").Value = wsInput.Cells(i, "E").Value ' 担当部署 ' 転記先シートに格子状罫線 Dim rng As Range Set rng = wsTarget.Range(wsTarget.Cells(targetLastRow, "A"), wsTarget.Cells(targetLastRow, "E")) ' 横線は細く With rng.Borders(xlEdgeTop): .LineStyle = xlContinuous: .Weight = xlThin: End With With rng.Borders(xlEdgeBottom): .LineStyle = xlContinuous: .Weight = xlThin: End With ' 縦線は太く With rng.Borders(xlEdgeLeft): .LineStyle = xlContinuous: .Weight = xlMedium: End With With rng.Borders(xlEdgeRight): .LineStyle = xlContinuous: .Weight = xlMedium: End With With rng.Borders(xlInsideVertical): .LineStyle = xlContinuous: .Weight = xlMedium: End With ' 横線内部 With rng.Borders(xlInsideHorizontal): .LineStyle = xlContinuous: .Weight = xlThin: End With transferred = True End If Else ' シートが存在しない場合は新規プロジェクトとしてメッセージに追加 If InStr(newProjects, proj) = 0 Then newProjects = newProjects & proj & vbCrLf End If End If Set wsTarget = Nothing Next proj ' 新規プロジェクトがあれば表示 If newProjects <> "" Then MsgBox "以下のプロジェクトは新規です：" & vbCrLf & newProjects End If ' 転記有無のメッセージ If transferred Then MsgBox "番号 " & wsInput.Cells(i, "A").Value & " を転記しました。" Else MsgBox "新規入力がありません。" End If ' カーソルをシート1のA列の最後の入力行の1つ下に移動 Dim nextRow As Long nextRow = lastRow + 1 wsInput.Activate wsInput.Cells(nextRow, "A").Select ' シート①の最後の行の1つ下にも格子状罫線を適用（転記先と同じスタイル） Set rng = wsInput.Range(wsInput.Cells(nextRow, "A"), wsInput.Cells(nextRow, "E")) With rng.Borders(xlEdgeTop): .LineStyle = xlContinuous: .Weight = xlThin: End With With rng.Borders(xlEdgeBottom): .LineStyle = xlContinuous: .Weight = xlThin: End With With rng.Borders(xlEdgeLeft): .LineStyle = xlContinuous: .Weight = xlMedium: End With With rng.Borders(xlEdgeRight): .LineStyle = xlContinuous: .Weight = xlMedium: End With With rng.Borders(xlInsideVertical): .LineStyle = xlContinuous: .Weight = xlMedium: End With With rng.Borders(xlInsideHorizontal): .LineStyle = xlContinuous: .Weight = xlThin: End With
End Sub