fork download 
  1. Option Explicit
  2.  
  3. Dim this_month_1st As Date '処理月の1日
  4. Dim start_year As Long      '集計開始年
  5. Dim start_year_1st As Date
  6. Public Sub 受注実績まとめ()
  7.     Dim ws As Worksheet     'ワーク
  8.     Dim sh1 As Worksheet    '受注
  9.     Dim sh2 As Worksheet    '実績
  10.     Dim sh3 As Worksheet    'まとめ
  11.     Dim maxrow As Long
  12.     Dim maxcol As Long
  13.     Dim lrow As Long
  14.     Dim wrow As Long
  15.     Dim mrow As Long
  16.     Dim yyyy As Long
  17.     Dim mm As Long
  18.     Dim pkey As String
  19.     Dim key As String
  20.     Dim dkey As Variant
  21.     Dim col As Long
  22.     Dim r1c1str
  23.     Dim dicT As Object
  24.     Set dicT = CreateObject("Scripting.Dictionary")
  25.     Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))    '作業用シートを作成する
  26.     Set sh1 = Worksheets("JUTYU")
  27.     Set sh2 = Worksheets("JISSEKI")
  28.     Set sh3 = Worksheets("まとめ")
  29.     Application.ScreenUpdating = False
  30.     start_year = sh3.Cells(1, "B").Value
  31.     start_year_1st = DateSerial(start_year, 1, 1)
  32.     yyyy = Year(sh3.Cells(1, "D").Value)
  33.     mm = Month(sh3.Cells(1, "D").Value)
  34.     this_month_1st = DateSerial(yyyy, mm, 1)
  35.     maxcol = sh3.Cells(2, Columns.Count).End(xlToLeft).Column   'まとめシートの2行目の最終列を求める
  36.     sh3.Rows("3:" & Rows.Count).Clear    'まとめシートの3行以降をクリア
  37.     '作業用シートへJUTYUシートを転記する
  38.     wrow = 1
  39.     maxrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'JUTYUシート最終行を求める
  40.     For lrow = 2 To maxrow
  41.         ws.Cells(wrow, "A").Value = sh1.Cells(lrow, "J").Value        'コード１
  42.         ws.Cells(wrow, "B").Value = sh1.Cells(lrow, "M").Value        'コード２
  43.         ws.Cells(wrow, "C").Value = sh1.Cells(lrow, "C").Value        '品名1
  44.         ws.Cells(wrow, "D").Value = sh1.Cells(lrow, "L").Value        '品名2
  45.         ws.Cells(wrow, "E").Value = sh1.Cells(lrow, "A").Value        '日付
  46.         ws.Cells(wrow, "F").Value = sh1.Cells(lrow, "F").Value        '受注数量
  47.         '「コード１＋品名１＋品名２」に対応するコード２を辞書登録する
  48.         dkey = sh1.Cells(lrow, "J").Value & "|" & sh1.Cells(lrow, "C").Value & "|" & sh1.Cells(lrow, "L").Value
  49.         dicT(dkey) = sh1.Cells(lrow, "M").Value
  50.         wrow = wrow + 1
  51.     Next
  52.     '続けて、作業用シートへJISSEKIシートを転記する
  53.     maxrow = sh2.Cells(Rows.Count, "A").End(xlUp).Row '最終行を求める
  54.     For lrow = 2 To maxrow
  55.         ws.Cells(wrow, "A").Value = sh2.Cells(lrow, "F").Value        'コード１
  56.         ws.Cells(wrow, "C").Value = sh2.Cells(lrow, "B").Value        '品名1
  57.         ws.Cells(wrow, "D").Value = sh2.Cells(lrow, "E").Value        '品名2
  58.         ws.Cells(wrow, "E").Value = sh2.Cells(lrow, "A").Value        '日付
  59.         ws.Cells(wrow, "G").Value = sh2.Cells(lrow, "H").Value        '実績数量
  60.         'コード１＋品名１＋品名２　がJUTYUに存在するならコード2をJUTYUから拝借する
  61.         dkey = sh2.Cells(lrow, "F").Value & "|" & sh2.Cells(lrow, "B").Value & "|" & sh2.Cells(lrow, "E").Value
  62.         If dicT.exists(dkey) = True Then
  63.             ws.Cells(wrow, "B").Value = dicT(dkey)  'コード２
  64.         End If
  65.         wrow = wrow + 1
  66.     Next
  67.     '作業用シートをソートする（1回のSortで指定可能なキーは３つ迄なので、2回に分けてソートする）
  68.     ws.Activate
  69.     Range("A1").Sort key1:=Range("D1")
  70.     Range("A1").Sort key1:=Range("A1"), key2:=Range("B1"), key3:=Range("C1")
  71.     '作業用シートを順に処理し、まとめシートへ転記する
  72.     pkey = ""
  73.     mrow = -2
  74.     For lrow = 1 To wrow - 1
  75.         key = ws.Cells(lrow, "A").Value & "|" & ws.Cells(lrow, "B").Value & "|" & ws.Cells(lrow, "C").Value & "|" & ws.Cells(lrow, "D").Value
  76.         'コード１、コード２、品名１、品名２の何れかが変われば、グループが変わったことになる
  77.         If key <> pkey Then
  78.             'グループ変更時の処理
  79.             mrow = mrow + 5
  80.             '罫線上側
  81.             sh3.Range(sh3.Cells(mrow, 1), sh3.Cells(mrow, maxcol)).Borders(xlEdgeTop).LineStyle = xlContinuous
  82.             sh3.Cells(mrow, "F").Offset(0, 0).Value = "受注"
  83.             sh3.Cells(mrow, "F").Offset(1, 0).Value = "実績"
  84.             sh3.Cells(mrow, "F").Offset(2, 0).Value = "内示"
  85.             sh3.Cells(mrow, "F").Offset(3, 0).Value = "見込み"
  86.             sh3.Cells(mrow, "F").Offset(4, 0).Value = "合計"
  87.             sh3.Cells(mrow, "A").Value = ws.Cells(lrow, "A").Value  'コード１
  88.             sh3.Cells(mrow, "B").Value = ws.Cells(lrow, "B").Value  'コード２
  89.             sh3.Cells(mrow, "D").Value = ws.Cells(lrow, "C").Value  '品名1
  90.             sh3.Cells(mrow, "E").Value = ws.Cells(lrow, "D").Value  '品名2
  91.             '合計の計算式
  92.             For col = 7 To maxcol
  93.                 r1c1str = "r" & mrow & "c" & col & ":r" & mrow + 3 & "c" & col
  94.                 sh3.Cells(mrow + 4, col).FormulaR1C1 = "=SUM(" & r1c1str & ")"
  95.                 sh3.Cells(mrow + 4, col).NumberFormatLocal = "#"
  96.             Next
  97.         End If
  98.         '受注数量の加算
  99.         If ws.Cells(lrow, "F").Value <> "" Then
  100.             '受注数量が空白でないなら、日付から加算対象となる列を算出する
  101.             col = GetIndex(ws.Cells(lrow, "E").Value, 1)
  102.             If col > 0 Then
  103.                 '加算対象となる列があるなら、その列へ加算する
  104.                 sh3.Cells(mrow, col).Value = sh3.Cells(mrow, col).Value + ws.Cells(lrow, "F").Value         '受注
  105.             End If
  106.         End If
  107.         '実績数量の加算
  108.         If ws.Cells(lrow, "G").Value <> "" Then
  109.             '実績数量が空白でないなら、日付から加算対象となる列を算出する
  110.             col = GetIndex(ws.Cells(lrow, "E").Value, 2)
  111.             If col > 0 Then
  112.                 '加算対象となる列があるなら、その列へ加算する
  113.                 sh3.Cells(mrow + 1, col).Value = sh3.Cells(mrow + 1, col).Value + ws.Cells(lrow, "G").Value '実績
  114.             End If
  115.         End If
  116.         pkey = key  '前回キーを記憶
  117.     Next
  118.     If mrow > 0 Then
  119.         '罫線下側
  120.         sh3.Range(sh3.Cells(mrow + 4, 1), sh3.Cells(mrow + 4, maxcol)).Borders(xlEdgeBottom).LineStyle = xlContinuous
  121.     End If
  122.     '作業用シートを削除（削除時、警告を出さないようにする）
  123.     Application.DisplayAlerts = False
  124.     'ws.Delete
  125.     Application.DisplayAlerts = True
  126.     Application.ScreenUpdating = True
  127.     sh3.Activate
  128.     sh3.Cells(1, 1).Select
  129.     MsgBox ("完了")
  130. End Sub
  131.  
  132. Private Function GetIndex(ByVal data_date As Date, ByVal kind As Long) As Long
  133.     Dim data_year As Long
  134.     GetIndex = -1
  135.     '集計開始年より前は、集計しない
  136.     If data_date < start_year_1st Then Exit Function
  137.     If kind = 1 Then
  138.         '受注の場合、処理月より前の月は処理しない
  139.         If data_date < this_month_1st Then Exit Function
  140.     Else
  141.         '実績の場合、処理月以降の月は処理しない
  142.         If data_date >= this_month_1st Then Exit Function
  143.     End If
  144.     '加算対象列の算出
  145.     data_year = Year(data_date)
  146.     GetIndex = 6 + (data_year - start_year) * 12 + Month(data_date)
  147. End Function
  148.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin 
Standard input is empty
stdout 
Standard output is empty
https://ideone.com/1njDuF
language:
Text (text 6.10)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!