[[20250717101436]]　『配車表一覧を得意先ことに振り分け』（事務員）　ページの最後に飛ぶ

『配車表一覧を得意先ことに振り分け』（事務員）

ご教授お願い致します。
毎日入力する配車表(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 ＞

Sub 転記_得意先別()

    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

開発タブって、ありますか？
開発→VisualBasic→挿入→標準モジュール　へ貼り付けてください

開発タブがなければホームタブにしてからアイコンとか並んでない空いてるとこで
右クリック→リボンのユーザー設定→コマンドの選択→メインタブ→開発→追加
で、追加できます
（通りすがり） 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

jindon様

ありがとうございます。
情報入力して、オートシェイプを押すとﾃﾞｰﾀは繁栄されるのですが、配車表に入力したやつが全て消えてしまいます💦
情報入力した配車表も保存したいです。
１日１枚単位で配車表は入力します。

また、入力後、仕事がキャンセルになった場合、その情報を配車表から削除すると、得意先一覧からも削除されるのでしょうか？
（事務員） 2025/07/18(金) 14:33:41

 >配車表に入力したやつが全て消えてしまいます

         Next
        .ClearContents   '<--- この行を削除
    End With
    SortSheets
End Sub

 >また、入力後、仕事がキャンセルになった場合、その情報を配車表から削除すると、得意先一覧からも削除されるのでしょうか？

 データ配置を含めた運用方法をもう一度考え直した方がよろしいかと...
 今のデータ構成ではどんなデータが[削除]されたのかを判定するのは難しいと思いますし、シート数がやたら増えていきますよね？
（jindon） 2025/07/18(金) 14:57:33

コメント返信：

[ 一覧(最新更新順) ]

[[20250717101436]] 『配車表一覧を得意先ことに振り分け』（事務員） ページの最後に飛ぶ

[[20250717101436]]　『配車表一覧を得意先ことに振り分け』（事務員）　ページの最後に飛ぶ