『配車表一覧を得意先ことに振り分け』（事務員）
ご教授お願い致します。
毎日入力する配車表(1日につきシート１枚）を自動で得意先ことに（１カ月につきシート１枚）転記する方法を教えて頂きたいです。
（例）
シート１
【配車表】 〇月▲日
NO. 車番 車両 乗務員 行き先１ 荷主 行き先２ 荷主 行き先３ 荷主
１ 11-11 あ a Ａ ｂ Ｂ ｚ Ａ
２ 11-12 い b Ｂ ｋ Ａ ｖ Ｂ
シート２
【配車表】 ■月〇日
3 11-13 う g Ａ
4 11-14 え a Ｂ
シート３
【得意先Ａ】
日付 車番 乗務員 行き先
〇月▲日 11-11 あ ａ
〇月▲日 11-12 い ｋ
〇月▲日 11-11 あ ｚ
■月〇日 11-13 う ｇ
シート４
【得意先Ｂ】
〇月▲日 11-11 あ ｂ
〇月▲日 11-12 い ｂ
■月〇日 11-14 え ａ
よろしくお願い致します。
＜ 使用 アプリ：、使用 OS：Windows11 ＞
Dim ws As Worksheet, destWs As Worksheet
Dim lastRow As Long, destLastRow As Long
Dim i As Long, j As Long
Dim dayStr As String, carNum As String, driver As String, destination As String, customer As String
Dim cell As Range
Dim destSheetName As String
Dim headerRow As Long: headerRow = 2 'ヘッダーが何行目か（必要に応じて修正）
'全てのシートを走査
For Each ws In ThisWorkbook.Worksheets
'得意先シートはスキップ
If Left(ws.Name, 4) = "得意先" Then GoTo Skip
'日付の取得（例：シート名から取る）
dayStr = ws.Range("A1").Value '必要ならA1以外も可
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'データ行を走査
For i = headerRow + 1 To lastRow
carNum = ws.Cells(i, 2).Value
driver = ws.Cells(i, 4).Value
'行き先1〜3と荷主1〜3（列5,6・7,8・9,10）を順番に処理
For j = 1 To 3
destination = ws.Cells(i, 4 + (j - 1) * 2 + 1).Value
customer = ws.Cells(i, 4 + (j - 1) * 2 + 2).Value
If customer <> "" Then
destSheetName = "得意先" & customer
'得意先シートが存在しない場合は作成
On Error Resume Next
Set destWs = ThisWorkbook.Worksheets(destSheetName)
If destWs Is Nothing Then
Set destWs = ThisWorkbook.Worksheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
destWs.Name = destSheetName
'ヘッダー
destWs.Range("A1").Value = "日付"
destWs.Range("B1").Value = "車番"
destWs.Range("C1").Value = "乗務員"
destWs.Range("D1").Value = "行き先"
End If
On Error GoTo 0
'得意先シートの最終行
destLastRow = destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1
'転記
destWs.Cells(destLastRow, 1).Value = dayStr
destWs.Cells(destLastRow, 2).Value = carNum
destWs.Cells(destLastRow, 3).Value = driver
destWs.Cells(destLastRow, 4).Value = destination
End If
Next j
Next i
Skip:
Set destWs = Nothing
Next ws
MsgBox "得意先別に転記完了しました"
End Sub
シート構成例：
[7月1日] [7月2日] … [7月31日] [得意先A] [得意先B] [得意先C]
【得意先A】シートには月分のデータが縦積み
日付 車番 乗務員 行き先 7/1 11-11 山田 東京 7/2 11-12 佐藤 大阪 7/2 11-11 山田 名古屋 7/3 11-13 鈴木 横浜
こんなイメージのもと、作成しました。
（通りすがり） 2025/07/17(木) 12:43:59
大変お恥ずかしいのですが・・・これはマクロというものでしょうか？
マクロに関しては全くの無知で・・・
どのセルに入力すればいいのでしょうか？
（事務員） 2025/07/18(金) 10:21:53
開発タブがなければホームタブにしてからアイコンとか並んでない空いてるとこで
右クリック→リボンのユーザー設定→コマンドの選択→メインタブ→開発→追加
で、追加できます
（通りすがり） 2025/07/18(金) 11:57:31
VBA 1) 配車表のB1に日付(シリアル値)が入力されている 2) 配車表の2行目に列項目がありデータは3行目から 3) 得意先シート名は 荷主名_yyyy年mm月"、例 A_2025年07月 等 4) 転記後は元データを消去 5) 転記後対象シートをシート名の昇順で並べ替え
使用方法 1) 配車表シートのシート見出しを右クリック-[コードの表示] 2) 右空白部分に下記コードを張り付け
Sub test()
Dim myMonth$, i&, ii&, wsName$, x, r As Range
Set r = [L2]
If Not IsDate(r) Then MsgBox r.Address(0, 0) & "に日付がありません": Exit Sub
If [A4] = "" Then Exit Sub
myMonth = Format$([b1], "yyyy年mm月")
With Range("a4", Range("a" & Rows.Count).End(xlUp)).Resize(, Cells.SpecialCells(11).Column)
For i = 1 To .Rows.Count
For ii = 6 To .Columns.Count Step 2
If .Cells(i, ii) <> "" Then
wsName = Join(Array(.Cells(i, ii), myMonth), "_")
If Not Evaluate("isref('" & wsName & "'!a1)") Then
Sheets.Add(, Sheets(Sheets.Count)).Name = wsName
Sheets(wsName).[a1:d1] = [{"日付","車番","乗務員","行き先"}]
End If
x = Application.Index(.Value, i, Array(2, 4, ii - 1))
With Sheets(wsName).Range("a" & Rows.Count).End(xlUp)(2)
r.Copy .Cells(1)
.Range("b1").Resize(, 3) = x
End With
End If
Next
Next
.ClearContents
End With
SortSheets
End Sub
Private Sub SortSheets()
Dim i&, ii&, temp, n&, t&, wsList
ReDim wsList(1 To ThisWorkbook.Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name Like "*_####年##月" Then
n = n + 1: wsList(n) = Sheets(i).Name
End If
Next
If n Then
t = ThisWorkbook.Sheets.Count - n + 1
For i = 1 To n - 1
For ii = i + 1 To n
If wsList(i) < wsList(ii) Then
temp = wsList(i): wsList(i) = wsList(ii): wsList(ii) = temp
End If
Next
Next
Application.ScreenUpdating = False
For i = 1 To n
Sheets(wsList(i)).Move Sheets(t)
Next
Application.ScreenUpdating = True
End If
End Sub
3) Alt+F11でエクセル画面に戻る 4) 配車表シートの適当な場所にオートシェイプを挿入 5) 4)のオートシェイプを右クリック-[マクロの登録] リストから***.testを選択して[OK] （jindon） 2025/07/18(金) 12:16:06 Edit: 14:12 >※L2に日付入力
>※３行目に項目 >(A3→NO./B3→車番/C3→車両/D3→乗務員/E3→配送先１ > Ｆ3→荷主/G3→配送先２/H3→荷主/I3→配送先３/J3→荷主/K3→配送先４/L3→荷主
>※４行目から情報入力
※L2に日付入力
※３行目に項目
(A3→NO./B3→車番/C3→車両/D3→乗務員/E3→配送先１
Ｆ3→荷主/G3→配送先２/H3→荷主/I3→配送先３/J3→荷主/K3→配送先４/L3→荷主
※４行目から情報入力
■同じ人が１日で何件も得意先を回るので、配車表は１行目(B4)はＡさん、２行目(B5)はＣさん・・・と入力するフォーマットになっています。
■荷主シートには、日付/車番/車両/乗務員/配送先を転記できるようにしたいです。
よろしくお願い致します。
（事務員） 2025/07/18(金) 13:49:10
ありがとうございます。
情報入力して、オートシェイプを押すとﾃﾞｰﾀは繁栄されるのですが、配車表に入力したやつが全て消えてしまいます💦
情報入力した配車表も保存したいです。
１日１枚単位で配車表は入力します。
また、入力後、仕事がキャンセルになった場合、その情報を配車表から削除すると、得意先一覧からも削除されるのでしょうか？
（事務員） 2025/07/18(金) 14:33:41
>配車表に入力したやつが全て消えてしまいます
Next
.ClearContents '<--- この行を削除
End With
SortSheets
End Sub
>また、入力後、仕事がキャンセルになった場合、その情報を配車表から削除すると、得意先一覧からも削除されるのでしょうか？
データ配置を含めた運用方法をもう一度考え直した方がよろしいかと... 今のデータ構成ではどんなデータが[削除]されたのかを判定するのは難しいと思いますし、シート数がやたら増えていきますよね？ （jindon） 2025/07/18(金) 14:57:33
ご教示ありがとうございました。
＞シート数がやたら増えていきますよね？
の件ですが、毎日の配車表も保存しないとダメなので、シート数が増えるのは仕方なくて(;'∀')
毎月、最終日、データ変更がない状態で【確定】を押してデータを反映させることにします(｀･ω･´)ゞ
（事務員） 2025/07/22(火) 10:01:34
>毎日の配車表も保存しないとダメなので、シート数が増えるのは仕方なくて データ入力シートを一枚にすればそれで済みますよね？ キャンセルの場合もフラグを立ててその理由も保持(後に削除も出来る)
例として
日付 車番 乗務員 行き先 キャンセル 備考
とでもしておけば、データは蓄積されフィルタ・ピボットテーブル機能等も使用できます。
データ構成は最も大事な基礎です。 （jindon） 2025/07/22(火) 10:55:07
＞毎日、日毎シートは必要なの？
月の最後に、あれば良いの？
配車表も１年間保存しないとダメなので、毎日、日ごとシート必要です(;'∀')
（事務員） 2025/07/22(火) 11:25:30
' 📌 ?@ 得意先別集計マクロ
Sub 得意先別_集計()
Dim ws As Worksheet, destWs As Worksheet
Dim lastRow As Long, destRow As Long, i As Long
Dim customer As String, targetSheet As String
Dim dayStr, carNum, driver, destination, cancel, remark
Application.ScreenUpdating = False
' 得意先シート初期化
Dim w As Worksheet
For Each w In ThisWorkbook.Sheets
If Left(w.Name, 4) = "得意先" Then
w.Range("A2:F10000").ClearContents
End If
Next
' 日別シート走査
For Each ws In ThisWorkbook.Sheets
If InStr(ws.Name, "月") > 0 And InStr(ws.Name, "日") > 0 Then
dayStr = ws.Range("A1").Value
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For i = 3 To lastRow
carNum = ws.Cells(i, 2).Value
driver = ws.Cells(i, 3).Value
destination = ws.Cells(i, 4).Value
customer = ws.Cells(i, 5).Value
cancel = ws.Cells(i, 6).Value
remark = ws.Cells(i, 7).Value
If customer <> "" Then
targetSheet = "得意先" & customer
On Error Resume Next
Set destWs = Sheets(targetSheet)
If destWs Is Nothing Then
Set destWs = Sheets.Add(After:=Sheets(Sheets.Count))
destWs.Name = targetSheet
destWs.Range("A1:F1").Value = Array("日付", "車番", "乗務員", "行き先", "キャンセル", "備考")
End If
On Error GoTo 0
destRow = destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1
destWs.Range("A" & destRow).Resize(1, 6).Value = Array(dayStr, carNum, driver, destination, cancel, remark)
End If
Next i
End If
Next ws
Application.ScreenUpdating = True
MsgBox "✅ 得意先別集計 完了"
End Sub
' 📌 ?A 新しい日付シート作成マクロ
Sub 新規日付シート追加()
Dim lastSheet As Worksheet, newSheet As Worksheet
Dim latestDate As Date, tmpDate As Date
Dim sheetName As String, newDate As Date
Dim ws As Worksheet
' 雛形シート使用（名前：雛形）
Set lastSheet = Sheets("雛形")
latestDate = DateSerial(2000, 1, 1)
' 日付最大値検索
For Each ws In Sheets
If InStr(ws.Name, "月") > 0 And InStr(ws.Name, "日") > 0 Then
On Error Resume Next
tmpDate = DateValue(ws.Range("A1").Value)
If tmpDate > latestDate Then latestDate = tmpDate
On Error GoTo 0
End If
Next ws
If latestDate = DateSerial(2000, 1, 1) Then
MsgBox "⚠️ 日付が検出できません。A1の確認を！"
Exit Sub
End If
newDate = latestDate + 1
sheetName = Month(newDate) & "月" & Day(newDate) & "日"
lastSheet.Copy After:=Sheets(Sheets.Count)
Set newSheet = ActiveSheet
newSheet.Name = sheetName
newSheet.Range("A1").Value = Format(newDate, "m月d日")
MsgBox sheetName & " シート作成完了 ✅"
End Sub
' 📌 ?B ボタン設置マクロ
Sub ボタン設置()
Dim btn As Button
Dim ws As Worksheet
Set ws = ActiveSheet ' 現在のシートにボタン作成
' 得意先別集計ボタン
Set btn = ws.Buttons.Add(50, 30, 150, 30)
With btn
.OnAction = "得意先別_集計"
.Caption = "得意先別集計 実行"
.Name = "btn得意先"
End With
' 日付シート追加ボタン
Set btn = ws.Buttons.Add(50, 70, 150, 30)
With btn
.OnAction = "新規日付シート追加"
.Caption = "翌日シート追加"
.Name = "btn日付"
End With
MsgBox "✅ ボタン設置完了"
End Sub
こんな感じは、どうですか？
（通りすがり） 2025/07/22(火) 12:47:29
ありがとうございます！
Set lastSheet = Sheets("雛形")の部分が、実行エラーと出たのですが、どう対処したらよろしいでしょうか？
（事務員） 2025/07/22(火) 12:58:20
随時入力シートを追加していく手法は賛成できませんが、どうしてもというころなら。
アップしたファイルはシートが1枚(配車表)だけものです。 配車表にあるボタンは配車表シートをコピーして新規の配車表シートを作成します。 なので、元の配車表シートはテンプレートとしての使用なのでデータを記入しないでください。
新規作成された配車表シートにあるボタンをクリックするとデータを対象シートに転記します。 配車表のデータを削除、又は追加した際にもボタンをクリックすると更新します。
https://www.dropbox.com/scl/fi/5dxul0bak6pc52kihi0ui/.xlsm?rlkey=5224sosgt5no18w6wg24b3wle&st=h1a6g12d&dl=0
（jindon） 2025/07/22(火) 14:38:39
' 📌 ?@ 得意先別集計マクロ
Sub 得意先別_集計()
Dim ws As Worksheet, destWs As Worksheet
Dim lastRow As Long, destRow As Long, i As Long
Dim customer As String, targetSheet As String
Dim dayStr, carNum, driver, destination, cancel, remark
Application.ScreenUpdating = False
' 得意先シート初期化
Dim w As Worksheet
For Each w In ThisWorkbook.Sheets
If Left(w.Name, 4) = "得意先" Then
w.Range("A2:F10000").ClearContents
End If
Next
' 日別シート走査
For Each ws In ThisWorkbook.Sheets
If InStr(ws.Name, "月") > 0 And InStr(ws.Name, "日") > 0 Then
dayStr = ws.Range("A1").Value
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For i = 3 To lastRow
carNum = ws.Cells(i, 2).Value
driver = ws.Cells(i, 3).Value
destination = ws.Cells(i, 4).Value
customer = ws.Cells(i, 5).Value
cancel = ws.Cells(i, 6).Value
remark = ws.Cells(i, 7).Value
If customer <> "" Then
targetSheet = "得意先" & customer
On Error Resume Next
Set destWs = Sheets(targetSheet)
If destWs Is Nothing Then
Set destWs = Sheets.Add(After:=Sheets(Sheets.Count))
destWs.Name = targetSheet
destWs.Range("A1:F1").Value = Array("日付", "車番", "乗務員", "行き先", "キャンセル", "備考")
End If
On Error GoTo 0
destRow = destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1
destWs.Range("A" & destRow).Resize(1, 6).Value = Array(dayStr, carNum, driver, destination, cancel, remark)
End If
Next i
End If
Next ws
Application.ScreenUpdating = True
MsgBox "✅ 得意先別集計 完了"
End Sub
' 📌 ?A 新しい日付シート作成マクロ
Sub 新規日付シート追加()
Dim lastSheet As Worksheet, newSheet As Worksheet
Dim latestDate As Date, tmpDate As Date
Dim sheetName As String, newDate As Date
Dim ws As Worksheet
' 雛形シート使用（名前：雛形）
Set lastSheet = Sheets("雛形")
latestDate = DateSerial(2000, 1, 1)
' 日付最大値検索
For Each ws In Sheets
If InStr(ws.Name, "月") > 0 And InStr(ws.Name, "日") > 0 Then
On Error Resume Next
tmpDate = DateValue(ws.Range("A1").Value)
If tmpDate > latestDate Then latestDate = tmpDate
On Error GoTo 0
End If
Next ws
If latestDate = DateSerial(2000, 1, 1) Then
MsgBox "⚠️ 日付が検出できません。A1の確認を！"
Exit Sub
End If
newDate = latestDate + 1
sheetName = Month(newDate) & "月" & Day(newDate) & "日"
lastSheet.Copy After:=Sheets(Sheets.Count)
Set newSheet = ActiveSheet
newSheet.Name = sheetName
newSheet.Range("A1").Value = Format(newDate, "m月d日")
MsgBox sheetName & " シート作成完了 ✅"
End Sub
' 📌 ?B ボタン設置マクロ
Sub ボタン設置()
Dim btn As Button
Dim ws As Worksheet
Set ws = ActiveSheet ' 現在のシートにボタン作成
' 得意先別集計ボタン
Set btn = ws.Buttons.Add(50, 30, 150, 30)
With btn
.OnAction = "得意先別_集計"
.Caption = "得意先別集計 実行"
.Name = "btn得意先"
End With
' 日付シート追加ボタン
Set btn = ws.Buttons.Add(50, 70, 150, 30)
With btn
.OnAction = "新規日付シート追加"
.Caption = "翌日シート追加"
.Name = "btn日付"
End With
MsgBox "✅ ボタン設置完了"
End Sub
＞この文字をすべてコピーして、一度に貼り付けすればよいのでしょうか？
それとも、それぞれ項目ことにシートが違うのでしょうか？
無知で申し訳ありません( ；∀；)
（事務員） 2025/07/22(火) 15:40:22
あ、一度に↑へ貼り付けて下さい
✅ マクロ実行までの基本流れ（初心者向け）
?@ 【開発タブを表示】
- ファイル → オプション → リボンのユーザー設定 → 「開発」に✅チェック
?A 【VBAエディターを開く】
?B 【マクロを貼り付け】
?C 【コンパイルチェック（エラー確認）】
- ✅ 何も起こらなければOK（コンパイル成功） - ❌ 赤くなる or エラーが出たらコード見直し
?D 【マクロの保存】
?E 【マクロ実行】
（通りすがり） 2025/07/22(火) 18:11:37
私の 2025/07/22(火) 14:38:39 に対する返信が無いようなので、私はここまでとします。 株式会社**物流のような物流会社なら基幹システムが導入されているはず。 Excelで何がしたいのだろう... （jindon） 2025/07/22(火) 18:59:40
jindon様
お返事遅くなって申し訳ありません。
今朝、jindon様が貼り付けてくださったやつを使用して確認してみていました！
素晴らしいものありがとうございます！！
質問なのですが、
＞配車表にあるボタンは配車表シートをコピーして新規の配車表シートを作成します。
配車表のシートは、その日にその日分しか作成できないのですか？
“配車表-〇年〇月〇日は既に存在します”
と出てしまいます。
何日分の配車をその日に入力したいのですが、どう対処すればよいでしょうか？
あと・・・日付をK2に表示されるようにして頂きたいです。
よろしくお願い致します。
（事務員） 2025/07/23(水) 10:32:53
何度も申し訳ございません。
＞配車表のデータを削除、又は追加した際にもボタンをクリックすると更新します
この部分ですが、追加は反映されるのですが、削除は反映されません。
（事務員） 2025/07/23(水) 10:48:53
私にはあなたがどのように使用しているのかわかりません。
>何日分の配車をその日に入力したいのですが こんなの想定に無いし、後出しは厳禁。
もう一度最初からどのようなシートがあってどのようなシートにどのように転記して どのように追加・削除した時にどのシートを更新するのか 詳細に誰にでも理解できるようにわかりやすく説明してください。 これは質問者の最低限の義務です。
他の回答者が解答らしきものをレスされているので、混乱を避けるためにも私は暫く静観します。 （jindon） 2025/07/23(水) 11:15:33
ありがとうございます
翌日シート追加を押すと、
？？日付が検出できません。A1の確認を。
と表示されます。
対処方法教えてください。
（事務員） 2025/07/23(水) 12:38:30
後だし追加申し訳ありません。
日付ですが、K2に表示されるようにお願いしたいです。
（事務員） 2025/07/23(水) 12:40:04
文字置き換えで、できます
（通りすがり） 2025/07/23(水) 12:53:48
ありがとうございます。
A1は何個くらいありますか？
もし、車番等項目が３行目にズレルとしたら、それも文字置き換えで対処できるのでしょうか？
１行目は➠配車表
２行目➠K２に日付
３行目➠項目
４行目〜➠データ入力
としたいです。
後々から言って申し訳ないのですが、触りながらやっているので・・・すいません。
（事務員） 2025/07/23(水) 13:07:32
Dim ws As Worksheet
Dim targetWs As Worksheet
Dim lastRow As Long, pasteRow As Long
Dim i As Long
Dim customer As String
Dim dataDate As String
Dim destSheetName As String
Set ws = ActiveSheet
dataDate = ws.Range("K2").Value ' 日付をK2から取得
lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row ' B列を基準に最終行取得
For i = 4 To lastRow ' ★データは4行目から
customer = ws.Cells(i, 6).Value ' 荷主（得意先）をF列から取得
If customer <> "" Then
destSheetName = "得意先" & customer
' シートがなければ作成
On Error Resume Next
Set targetWs = Sheets(destSheetName)
If targetWs Is Nothing Then
Set targetWs = Sheets.Add(After:=Sheets(Sheets.Count))
targetWs.Name = destSheetName
' 見出しを作成
With targetWs
.Range("A1").Value = "日付"
.Range("B1").Value = "車番"
.Range("C1").Value = "乗務員"
.Range("D1").Value = "行き先"
.Range("E1").Value = "キャンセル"
.Range("F1").Value = "備考"
End With
End If
On Error GoTo 0
' 転記
With targetWs
pasteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(pasteRow, 1).Value = dataDate
.Cells(pasteRow, 2).Value = ws.Cells(i, 2).Value ' 車番（B列）
.Cells(pasteRow, 3).Value = ws.Cells(i, 3).Value ' 乗務員（C列）
.Cells(pasteRow, 4).Value = ws.Cells(i, 4).Value ' 行き先１（D列）
.Cells(pasteRow, 5).Value = ws.Cells(i, 7).Value ' キャンセル（G列）
.Cells(pasteRow, 6).Value = ws.Cells(i, 8).Value ' 備考（H列）
End With
End If
Next i
MsgBox "得意先別シートへの転記が完了しました。", vbInformation
End Sub
（通りすがり） 2025/07/23(水) 20:18:17
ありがとうございます。
上記、ご教示いただきましたものを試してみたのですが、うまくいきませんでした。
データ入力してみたのですが、何も反映されませんでした。
（事務員） 2025/07/24(木) 10:06:53
#### 🔍【1】K2セルの確認
- OK → `2025/7/22` のような **日付形式** - NG → `7月22日` や `"文字列扱い"` だと失敗します
#### 🔍【2】4行目からの入力
| 列 | 内容 | 必須か？ |
|-----|--------------|---------|
| B列 | 車番 | ○ 必須 |
| C列 | 乗務員 | ○ 必須 |
| D列 | 行き先１ | ○ 必須 |
| F列 | 荷主（得意先） | ○ 必須 |
| G列 | キャンセル | 任意 |
| H列 | 備考 | 任意 |
#### 🔍【3】得意先シートができたか？
- 追加されていない場合：
- `F列（荷主）` が空である可能性あり
- マクロが実行されていない可能性あり
#### 🔍【4】テストデータ例（4行目〜）
| B列 | C列 | D列 | F列 | G列 | H列 |
|--------|--------|------|-----|-----|-----|
| 11-11 | 山田 | 東京 | A | | |
| 22-22 | 佐藤 | 大阪 | B | ○ | 渋滞あり |
➡️ `K2` に `2025/7/22` を入力してからマクロを実行してください
#### 🔍【5】それでもダメなら教えてほしいこと
1. **K2 には何が入力されてますか？**
2. **何行目からどんなデータを入力しましたか？**
3. **「得意先A」などのシートは新しくできましたか？**
4. **エラーが出た場合、その内容（メッセージ）を教えてください**
（通りすがり） 2025/07/24(木) 12:41:21
ご回答ありがとうございます。
#### 🔍【1】K2セルの確認 →2025/7/24形式で入力しています。
#### 🔍【2】4行目からの入力
→４行目からの入力です。
■１行目→Ａ〜Ｌ・・・セル結合して、配車表と入力
■２行目→Ｋ２に日付入力
■３行目→項目入力
(A/行NO.、B/車番、C/車種、D/乗務員、E/配送先1、F/荷主、G/配送先2、H/荷主、I/配送先3、J/荷主、K/配送先4、L/荷主、M/備考）
→このようなレイアウトで作成可能でしょうか？
また、得意先からデータを削除する場合は、“キャンセル”と入力しないと、削除されないのでしょうか？
配車表の入力したデータをクリアしたら、得意先シートから自動で削除されるようなことは可能でしょうか？
（事務員） 2025/07/24(木) 15:30:31
Option Explicit
Sub 得意先別集計_最新状態に再構成()
Dim ws As Worksheet, tgtWs As Worksheet
Dim lastRow As Long, i As Long
Dim destRow As Long
Dim 日付 As String, 荷主 As String
Dim 行先 As String, 車番 As String, 乗務員 As String
Dim dict As Object
Dim j As Integer
Dim 荷主列 As Variant, 行先列 As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' 既存の「得意先」シートを削除
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "得意先*" Then ws.Delete
Next ws
Set dict = CreateObject("Scripting.Dictionary")
' 各日付シート（1日1シート）を順に処理
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "得意先*" Or ws.Name = "雛形" Then GoTo NextSheet
' 日付取得（K2セル）
日付 = Trim(ws.Range("K2").Text)
If 日付 = "" Then GoTo NextSheet
' データの最終行（B列）
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
' 各行を処理（4行目以降）
For i = 4 To lastRow
' キャンセル判定（G列 = "キャンセル"）
If LCase(Trim(ws.Cells(i, "G").Value)) = "キャンセル" Then GoTo NextRow
車番 = Trim(ws.Cells(i, "B").Value)
乗務員 = Trim(ws.Cells(i, "D").Value)
荷主列 = Array(6, 8, 10, 12) ' F, H, J, L
行先列 = Array(5, 7, 9, 11) ' E, G, I, K
For j = 0 To 3
If Trim(ws.Cells(i, 荷主列(j)).Value) <> "" Then
荷主 = Trim(ws.Cells(i, 荷主列(j)).Value)
行先 = Trim(ws.Cells(i, 行先列(j)).Value)
' 得意先シート作成（初回のみ）
If Not dict.exists(荷主) Then
Set tgtWs = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
tgtWs.Name = "得意先" & 荷主
tgtWs.Range("A1:D1").Value = Array("日付", "車番", "乗務員", "行先")
dict.Add 荷主, tgtWs
Else
Set tgtWs = dict(荷主)
End If
' 転記
destRow = tgtWs.Cells(tgtWs.Rows.Count, 1).End(xlUp).Row + 1
tgtWs.Cells(destRow, 1).Value = 日付
tgtWs.Cells(destRow, 2).Value = 車番
tgtWs.Cells(destRow, 3).Value = 乗務員
tgtWs.Cells(destRow, 4).Value = 行先
End If
Next j
NextRow:
Next i
NextSheet:
Next ws
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "得意先別の集計が完了しました。", vbInformation
End Sub
（通りすがり） 2025/07/24(木) 18:53:25
[[20250713005155]] の（xyz）さんの 2025/07/25(金) 16:42:01 の投稿をよく読みなさい。
他の（通りすがり）さんにも迷惑。
（立ち寄り） 2025/07/25(金) 17:33:50
LLMの回答をそのままコピペするなら、そう明記するべきかと思いますね 質問者さんもこんな奴に聞かないで直接ChatGPTに聞いた方が早いですよ笑 （デボラ） 2025/07/25(金) 18:53:56
>配車表のシートは、その日にその日分しか作成できないのですか？ 同日の配車表が重複する場合は配車表_yyyy年mm月dd日_hhmmssを時刻を付加
>日付をK2に表示されるようにして頂きたいです。 済み
配車表の[荷主]の無いものは削除されたものとみなします。
Sub test()
Dim a, w, myDate As Date, ym$, i&, ii&, iii&, wsName$
Dim x(1), e, s$, flg As Boolean, ws As Worksheet, dic As Object
If Not IsDate([K2]) Then MsgBox "K2 に日付がありません": Exit Sub
If [A4] = "" Then Exit Sub
myDate = [K2]: wsName = ActiveSheet.Name
Set dic = CreateObject("Scripting.Dictionary")
ym = Format$(myDate, "yyyy年mm月")
a = Range("a4", Range("a" & Rows.Count).End(xlUp)).Resize(, Cells.SpecialCells(11).Column).Value2
For i = 1 To UBound(a, 1)
For ii = 6 To UBound(a, 2) Step 2
If a(i, ii) <> "" Then
s = a(i, ii) & "_" & ym
If Not dic.exists(s) Then
ReDim w(1 To 5, 1 To 1)
Else
w = dic(s)
ReDim Preserve w(1 To 5, 1 To UBound(w, 2) + 1)
End If
w(1, UBound(w, 2)) = myDate
w(2, UBound(w, 2)) = a(i, 3): w(3, UBound(w, 2)) = a(i, 4)
w(4, UBound(w, 2)) = a(i, ii - 1)
w(5, UBound(w, 2)) = ActiveSheet.Name
dic(s) = w
End If
Next
Next
For Each e In dic
If Not Evaluate("isref('" & e & "'!a1)") Then
Sheets.Add(, Sheets(Sheets.Count)).Name = e
Sheets(e).[a1:e1] = [{"日付","車番","乗務員","行き先","参照"}]
Sheets(e).Columns.AutoFit
End If
Next
For Each ws In Worksheets
If ws.Name Like "*_" & ym Then
s = ws.Name
With ws
.[a1].CurrentRegion.Sort .Columns(1), 1, .Columns(5), Header:=1
x(0) = .Evaluate("min(if((a1:a50000=" & CLng(myDate) & ")*(e1:e50000=""" & wsName & """),row(1:50000)))")
x(1) = .Evaluate("max(if((a1:a50000=" & CLng(myDate) & ")*(e1:e50000=""" & wsName & """),row(1:50000)))")
If Not IsError(x(0)) Then
If x(0) > 0 Then .Rows(x(0) & ":" & x(1)).Delete
End If
If dic.exists(s) Then
With .Range("a" & Rows.Count).End(xlUp)(2).Resize(UBound(dic(s), 2), 5)
.Value = Application.Transpose(dic(s))
.Columns(1).NumberFormatLocal = "yyyy/mm/dd"
End With
End If
.[a1].CurrentRegion.Sort .Columns(1), 1, .Columns(5), Header:=1
.Columns.AutoFit
End With
End If
Next
SortSheets
Sheets(wsName).Select
End Sub
Sub SortSheets()
Dim i&, ii&, temp, n&, t&, wsList
ReDim wsList(1 To ThisWorkbook.Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name Like "*_####年##月" Then
n = n + 1: wsList(n) = Sheets(i).Name
End If
Next
If n Then
t = ThisWorkbook.Sheets.Count - n + 1
For i = 1 To n - 1
For ii = i + 1 To n
If wsList(i) < wsList(ii) Then
temp = wsList(i): wsList(i) = wsList(ii): wsList(ii) = temp
End If
Next
Next
Application.ScreenUpdating = False
For i = 1 To n
Sheets(wsList(i)).Move Sheets(t)
Next
Application.ScreenUpdating = True
End If
End Sub
Sub CopySheet()
If ActiveSheet.Name <> "配車表" Then Exit Sub
Sheets("配車表").Copy , Sheets("配車表")
With ActiveSheet
.[K2] = Date
With .Shapes(1)
.OnAction = "test"
.TextFrame.Characters.Text = "更新"
.TextFrame.Characters.Font.Bold = True
End With
.Name = GetWsName(Date)
End With
End Sub
Function GetWsName(d As Date) As String
GetWsName = "配車表 " & Format$(d, "yyyy年mm月dd日")
If Evaluate("isref('" & GetWsName & "'!a1)") Then GetWsName = GetWsName & "_" & Format$(Time, "hhmmss")
End Function
https://www.dropbox.com/scl/fi/dcu35xvf305dh4otzsz88/_ver3.xlsm?rlkey=80r1gsk9etwu98k2af5411og2&st=uics45oo&dl=0
（jindon） 2025/07/28(月) 14:42:44
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.