顧客管理システムから抽出した発注データ（Excel）から納品書を作成したいです。
・営業所ごと、発注者ごとに分けなくてはならない。
・発注商品ごとにExcelデータの行が分かれる。
などの要因から
納品書の自動化が難しいです。
Excel初心者でお恥ずかしいですが、
どうか、解決方法を教えていただければ幸いです。
抽出したデータは、顧客が同じなのに発注商品が複数ある場合別の行で表示されます。
例）
営業所A、顧客A情報、商品①
営業所A、顧客A情報、商品②
営業所B、顧客B情報、商品①
営業所A、顧客C情報、商品①
営業所A、顧客C情報、商品④
営業所ごとにさらに顧客情報を軸に
発注された商品を羅列する必要があります
例）抽出したデータ例より
ーーーーーーーーーー
営業所A 御中
下記の通り、納品します。
顧客A情報
発注内訳）商品①、商品②
顧客C情報
発注内訳）商品①、商品④
以上
ーーーーーーーーー
営業所B御中
下記の通り、納品します。
顧客B情報
発注内訳）商品①
以上
ーーーーーーーーーー
Excel初心者で大変お恥ずかしいですが、
Vlookpでの納品書作成を試みました。
しかし、同じ顧客が複数の別商品を発注した場合、別の行で表示されるので、
何度も同じ顧客名がでてきてしまいます。
どうすればいいのか分からず途方に暮れております。
何卒よろしくお願い申し上げます。
失礼ですが、Excel初心者の方が、この場のやりとりだだけで、目的を達成することは、なかなか難しいと思います。
企業システムと思われるので、ITベンダに依頼するのが、本来だとは思います。
どうしても、ご自身でやられるということであれば、以下の確認事項にお答えください。
確認事項
例）
営業所A、顧客A情報、商品①
↑このデータは、ExcelのA列、B列、C列 ということでしょうか？
顧客A情報
発注内訳）商品①、商品②
発注内訳の商品は、必ず横に並べる必要がありますか？
商品名が長いと、商品数が多いと、横に並べると印刷（PDF化）で切れてしまいませんか？
発注内訳）商品①、
商品②
のように縦に並べたらどうでしょうか？
@yamada041155
Questionerコメントありがとうございます。
本来であれば、プロにお願いしたいのですが、予算の都合上なるべく自力で行いたいと考えています。
例）
営業所A、顧客A情報、商品①
↑このデータは、ExcelのA列、B列、C列 ということでしょうか？
→はい。ExcelのA列、B列、C列です。
顧客A情報
発注内訳）商品①、商品②
発注内訳の商品は、必ず横に並べる必要がありますか？
商品名が長いと、商品数が多いと、横に並べると印刷（PDF化）で切れてしまいませんか？
発注内訳）商品①、
商品②
のように縦に並べたらどうでしょうか？
→縦に並べても問題ありません。ありがとうございます。
引き続き何卒よろしくお願い申し上げます。
「自力」で頑張ってください！
@yamada041155
Questionerコメントありがとうございます。
誤解を生む表現方法でした。失礼いたしました。
予算の都合上、プロにお金をお支払いし依頼するのが難しいため、
このような無料で教えていただけるプラットフォームを活用し、
皆さんのお力添えをいただきながら、作成したいという意味合いでございます。
以下の「発注データ」Excelを想定し、このExcelを最前面で開いている状態で。後で示すマクロ「納品書作成」を実行します。
1行目は見出し（列名）として、データとしては、2行目から始まる前提としました
（見出し行は無しで、1行目からデータが始まる前提とすることも可能）。
マクロにて納品書Excelを新規に作成し、営業所ごとのシートに、各営業所向けの納品データを作成します。
マクロで作成した納品書Excelは、自動では保存されないので、必要により「名前を付けて保存」してください。
以下のマクロで実現しています。
処理を簡単にするため、営業所×顧客×発注データの3重ループで発注データを捜査するため、営業所×顧客×発注データの件数が増えるほど、処理時間が長くなります。
発注データが数百〜数千件数にてマクロを実行すると、マクロ実行中はウインドウが無応答になります（件数が多いと真っ白な画面になることもある）が、これは想定内の動作です。何も触れずにマクロ終了まで我慢して待つこと。
想定される最大件数でテストして、処理時間の妥当性を確認すること。余りに時間が掛かるようなら、根本的に処理構造を変える必要があるかも。
Option Explicit
Const 開始行 = 2
Const 営業所列 = 1, 顧客列 = 2, 商品列 = 3
Sub 納品書作成()
Application.ScreenUpdating = False
Dim 発注書シート As Worksheet
Set 発注書シート = ActiveWorkbook.ActiveSheet
Dim 営業所名 As String, 顧客名 As String, 商品名 As String
Dim 営業所名と顧客名 As String
Dim row As Long, col As Long, outRow As Long
Dim dicE As Object '営業所
Set dicE = CreateObject("Scripting.Dictionary")
Dim dicEK As Object '営業所名+顧客名
Set dicEK = CreateObject("Scripting.Dictionary")
Dim 営業所s() As Variant, 営業所key As Variant
Dim 営業所名と顧客名s() As Variant, 営業所名と顧客名key As Variant
'Step1 辞書（dicE, dicEK）を作成
row = 開始行
Do While Not IsEmpty(Cells(row, 営業所列))
If IsEmpty(Cells(row, 顧客列)) Or IsEmpty(Cells(row, 商品列)) Then GoTo continue1
営業所名 = Cells(row, 営業所列)
顧客名 = Cells(row, 顧客列)
営業所名と顧客名 = 営業所名 & "+" & 顧客名
If Not dicE.exists(営業所名) Then dicE.Add 営業所名, 0
If Not dicEK.exists(営業所名と顧客名) Then dicEK.Add 営業所名と顧客名, 0
continue1:
row = row + 1
Loop
Call Dic昇順(dicE)
Call Dic昇順(dicEK)
'Step2 納品書 を作成するExcelブックを作成
Dim 納品書ブック As Workbook
Set 納品書ブック = Application.Workbooks.Add
'Step3 納品書 を作成
With 発注書シート
営業所s = dicE.keys
For Each 営業所key In 営業所s
営業所名 = CStr(営業所key)
Dim target As Worksheet
Set target = 納品書ブック.Worksheets.Add(before:=納品書ブック.Worksheets(納品書ブック.Worksheets.Count))
target.Name = 営業所名
target.Activate
Cells(1, 1) = 営業所名 & " 御中"
Cells(2, 1) = "下記の通り､納品します｡ "
outRow = 4
営業所名と顧客名s = dicEK.keys
For Each 営業所名と顧客名key In 営業所名と顧客名s
営業所名と顧客名 = CStr(営業所名と顧客名key)
If Left(営業所名と顧客名, Len(営業所名) + 1) <> (営業所名 & "+") Then GoTo continue2
顧客名 = Right(営業所名と顧客名, Len(営業所名と顧客名) - Len(営業所名) - 1)
Cells(outRow, 1) = 顧客名
outRow = outRow + 1
Dim 商品数 As Long: 商品数 = 0
row = 開始行
Do While Not IsEmpty(.Cells(row, 営業所列))
If (.Cells(row, 営業所列) <> 営業所名) Or (.Cells(row, 顧客列) <> 顧客名) Or IsEmpty(.Cells(row, 商品列)) Then GoTo continue3
商品名 = .Cells(row, 商品列)
If 商品数 = 0 Then Cells(outRow, 1) = "発注内訳）"
Cells(outRow, 2) = 商品名
outRow = outRow + 1
商品数 = 商品数 + 1
continue3:
row = row + 1
Loop
continue2:
Next
Cells(outRow, 1) = "以上"
Next
End With
Application.ScreenUpdating = True
Call MsgBox("完了しました。", vbInformation + vbOKOnly + vbSystemModal)
End Sub
'以下、内部処理
Private Sub showDic(dic As Object)
Dim str As String, n As Integer
Dim keys() As Variant, key As Variant
keys = dic.keys
For Each key In keys
str = str & key & " : " & dic.Item(key) & vbCrLf
Next
MsgBox str, vbInformation
End Sub
Private Sub Dic昇順(ByRef dic As Object)
Dim arrKeys As Variant
Dim arrList() As Variant
Dim n As Integer
arrKeys = dic.keys
ReDim arrList(dic.Count - 1, 1)
For n = LBound(arrKeys) To UBound(arrKeys)
arrList(n, 0) = arrKeys(n)
arrList(n, 1) = dic(arrKeys(n))
Next
Call QuickSort(arrList, LBound(arrList, 1), UBound(arrList, 1))
dic.RemoveAll
For n = LBound(arrList) To UBound(arrList)
dic.Add arrList(n, 0), arrList(n, 1)
Next
End Sub
Private Sub QuickSort(ByRef arrList() As Variant, ByVal minIDX As Long, ByVal maxIDX As Long)
Dim valMEDIAN As Variant
Dim arrTEMP() As Variant
Dim n As Long
Dim m As Long
n = minIDX
m = maxIDX
valMEDIAN = arrList(Int((minIDX + maxIDX) / 2), 0)
Do
Do While StrComp(arrList(n, 0), valMEDIAN) < 0
n = n + 1
Loop
Do While StrComp(arrList(m, 0), valMEDIAN) > 0
m = m - 1
Loop
If n >= m Then Exit Do
ReDim arrTEMP(0, 1)
arrTEMP(0, 0) = arrList(n, 0)
arrList(n, 0) = arrList(m, 0)
arrList(m, 0) = arrTEMP(0, 0)
arrTEMP(0, 1) = arrList(n, 1)
arrList(n, 1) = arrList(m, 1)
arrList(m, 1) = arrTEMP(0, 1)
Erase arrTEMP
n = n + 1
m = m - 1
Loop
If (minIDX < n - 1) Then Call QuickSort(arrList, minIDX, n - 1)
If (maxIDX > m + 1) Then Call QuickSort(arrList, m + 1, maxIDX)
End Sub