Excel　発注データから納品書を自動で作成したい

Comments

1. 

   @yamada041155

   Questioner

   more_horiz

   コメントありがとうございます。
   本来であれば、プロにお願いしたいのですが、予算の都合上なるべく自力で行いたいと考えています。

   例）
   営業所A、顧客A情報、商品①

   ↑このデータは、ExcelのA列、B列、C列 ということでしょうか？

   →はい。ExcelのA列、B列、C列です。

   顧客A情報
   発注内訳）商品①、商品②

   発注内訳の商品は、必ず横に並べる必要がありますか？
   商品名が長いと、商品数が多いと、横に並べると印刷（PDF化）で切れてしまいませんか？
   発注内訳）商品①、
   　　　　　商品②
   のように縦に並べたらどうでしょうか？

   →縦に並べても問題ありません。ありがとうございます。

   引き続き何卒よろしくお願い申し上げます。

2. 

   @midoribi

   more_horiz

   「自力」で頑張ってください！

3. 

   @yamada041155

   Questioner

   more_horiz

   コメントありがとうございます。
   誤解を生む表現方法でした。失礼いたしました。
   予算の都合上、プロにお金をお支払いし依頼するのが難しいため、
   このような無料で教えていただけるプラットフォームを活用し、
   皆さんのお力添えをいただきながら、作成したいという意味合いでございます。

4. 

   @nak435

   more_horiz

   以下の「発注データ」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