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