Option Explicit
Dim month_flg As Variant '到来月対応編集フラグ
Public Sub ①最優秀拠点部署()
Dim ws As Worksheet '管理シート
Dim ky_ws1 As Worksheet '拠点用順位シート①
Dim ky_ws2 As Worksheet '拠点用順位シート②
Dim bu_ws1 As Worksheet '部署用順位シート①
Dim bu_ws2 As Worksheet '部署用順位シート②
Dim folder As String 'フォルダー名
Dim bname As String '元データファイル名
Dim full_bname As String '元データファイル名フルパス
Dim arv_month As Variant '到来月
Dim srcbook As Workbook '元データブック
Dim i As Long
Set ky_ws1 = Worksheets("最優秀拠点経常利益")
Set ky_ws2 = Worksheets("最優秀拠点収支")
Set bu_ws1 = Worksheets("最優秀部署経常利益")
Set bu_ws2 = Worksheets("最優秀部署収支")
Set ws = Worksheets("管理")
folder = ws.Cells(2, "B").Value
bname = ws.Cells(2, "C").Value
arv_month = ws.Cells(2, "E").Value
'入力パラメータチェック
Call CheckParams(folder, bname, arv_month, full_bname)
If MsgBox("最優秀拠点・部署の順位シートを作成します", vbOKCancel) <> vbOK Then
Exit Sub
End If
Call set_month_flag(arv_month, month_flg)
'Call dump_flag(month_flg)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'抽出先シートクリア
Call sheet_clear(ky_ws1)
Call sheet_clear(ky_ws2)
Call sheet_clear(bu_ws1)
Call sheet_clear(bu_ws2)
'元データファイルの処理
Set srcbook = Workbooks.Open(full_bname)
Call sheet_rank(1, ky_ws1, ky_ws2, srcbook)
Call sheet_rank(2, bu_ws1, bu_ws2, srcbook)
srcbook.Close
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox ("完了")
End Sub
'入力パラメータチェック
Public Sub CheckParams(ByVal folder As String, ByVal bname As String, ByVal arv_month As Variant, ByRef full_bname As String)
Dim flag As Boolean
flag = False
If folder <> "" Then
If Dir(folder, vbDirectory) <> "" Then
flag = True
End If
End If
If flag = False Then
MsgBox ("フォルダ名エラー")
End
End If
flag = False
If bname <> "" Then
full_bname = folder & "\" & bname
If Dir(full_bname, vbNormal) <> "" Then
flag = True
End If
End If
If flag = False Then
MsgBox ("元データファイル名エラー")
End
End If
flag = False
If arv_month <> "" And IsNumeric(arv_month) = True And CLng(arv_month) = arv_month Then
If arv_month > 0 And arv_month < 13 Then
flag = True
End If
End If
If flag = False Then
MsgBox ("到来月エラー")
End
End If
End Sub
'順位シートの設定
Private Sub sheet_rank(ByVal mode As Long, ByVal ws1 As Worksheet, ByVal ws2 As Worksheet, ByVal wbook As Workbook)
Dim wn1 As String '作業シート名①
Dim wn2 As String '作業シート名②
Dim wk1 As Worksheet '作業①
Dim wk2 As Worksheet '作業②
Dim src_ws As Worksheet '元データのワークシート
Dim src_name As String '元データの拠点名／部署名
Dim src_col As Long '元データの月インデックス対応の開始カラム位置
Dim i As Long
Dim wk_row As Long '作業シートの行番号
Dim wk_col As Long '作業シートの月インデックス対応の開始カラム位置
ThisWorkbook.Activate
wn1 = "作業①"
wn2 = "作業②"
Dim ws As Worksheet '追加
For Each ws In Worksheets '追加
MsgBox ("<" & ws.Name & ">") '追加
Next '追加
Set wk1 = Worksheets(wn1)
Set wk2 = Worksheets(wn2)
wk1.Cells.ClearContents
wk2.Cells.ClearContents
wbook.Activate
wk_row = 0
'元データファイルのワークシート分繰り返し
For Each src_ws In Worksheets
'指定区分（1:拠点,2:部署）のワークシートなら処理する
If IsNumeric(src_ws.Range("A1").Value) = True Then
If src_ws.Range("A1").Value = mode Then
wk_row = wk_row + 1
src_name = src_ws.Range("B1").Value
'全月分繰り返す
For i = 0 To UBound(month_flg)
'当該月インデックスの月が到来済みなら処理する
If month_flg(i) = True Then
src_col = get_src_col_by_index(i)
wk_col = get_work_col_by_index(i)
If IsNumeric(src_ws.Cells(176, src_col + 21).Value) = False Then
MsgBox ("経常利益達成率不正")
src_ws.Cells(176, src_col + 21).Select
Application.Calculation = xlCalculationAutomatic
End
End If
'経常利益
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col).Value = src_name 'エリア／支店
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 1).Value = src_ws.Cells(176, src_col + 5).Value '粗利計画
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 2).Value = src_ws.Cells(176, src_col + 8).Value '粗利実績
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 3).Value = src_ws.Cells(176, src_col + 21).Value '達成率対計画金額
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 4).Value = src_ws.Cells(176, src_col + 22).Value '伸長額対計画金額
If IsNumeric(src_ws.Cells(181, src_col + 21).Value) = False Then
MsgBox ("収支 合計達成率不正")
src_ws.Cells(181, src_col + 21).Select
Application.Calculation = xlCalculationAutomatic
End
End If
'収支 合計
ThisWorkbook.Worksheets(wn2).Cells(wk_row, wk_col).Value = src_name 'エリア／支店
ThisWorkbook.Worksheets(wn2).Cells(wk_row, wk_col + 1).Value = src_ws.Cells(181, src_col + 5).Value '粗利計画
ThisWorkbook.Worksheets(wn2).Cells(wk_row, wk_col + 2).Value = src_ws.Cells(181, src_col + 8).Value '粗利実績
ThisWorkbook.Worksheets(wn2).Cells(wk_row, wk_col + 3).Value = src_ws.Cells(181, src_col + 21).Value '達成率対計画金額
ThisWorkbook.Worksheets(wn2).Cells(wk_row, wk_col + 4).Value = src_ws.Cells(181, src_col + 22).Value '伸長額対計画金額
End If
Next
End If
End If
Next
ThisWorkbook.Activate
Call sheet_rank_div(ws1, wk1, wk_row) '経常利益の設定
Call sheet_rank_div(ws2, wk2, wk_row) '収支 合計の設定
End Sub
'収支毎の順位シートの設定
Private Sub sheet_rank_div(ByVal ws As Worksheet, ByVal wk As Worksheet, ByVal maxrow As Long)
Dim i As Long
Dim wk_col As Long '作業シートの月インデックス対応の開始カラム位置
Dim tr_col As Long '順位シートの月インデックス対応の開始カラム位置
Dim wk_row As Long '作業シートの行番号
Dim stcol As String
Dim encol As String
Dim keycol As String
If maxrow = 0 Then Exit Sub
'全月分繰り返す
For i = 0 To UBound(month_flg)
If month_flg(i) = True Then
'作業シートを達成率降順でソート
wk_col = get_work_col_by_index(i)
tr_col = get_trg_col_by_index(i)
stcol = ConvertToLetter(wk_col)
encol = ConvertToLetter(wk_col + 4)
keycol = ConvertToLetter(wk_col + 4) '修正20190311
wk.Range(stcol & "1:" & encol & maxrow).Sort key1:=wk.Range(keycol & "1"), order1:=xlDescending
'順位シートへ対象全てコピー
For wk_row = 1 To maxrow
ws.Cells(wk_row + 4, tr_col + 1).Value = wk.Cells(wk_row, wk_col).Value 'エリア／支店
ws.Cells(wk_row + 4, tr_col + 2).Value = wk.Cells(wk_row, wk_col + 1).Value '粗利計画
ws.Cells(wk_row + 4, tr_col + 3).Value = wk.Cells(wk_row, wk_col + 2).Value '粗利実績
ws.Cells(wk_row + 4, tr_col + 4).Value = wk.Cells(wk_row, wk_col + 3).Value '達成率対計画金額
ws.Cells(wk_row + 4, tr_col + 5).Value = wk.Cells(wk_row, wk_col + 4).Value '伸長額対計画金額
Next
End If
Next
End Sub
'到来月管理テーブルの設定
Public Sub set_month_flag(ByVal arv_month As Variant, ByRef month_flg As Variant)
Dim month_arr As Variant
'到来月管理テーブルの設定
'10, 11, 12, 第1四半期, 1, 2, 3,第2四半期, 上半期, 4, 5, 6,第3四半期, 7, 8, 9,第4四半期,下半期,年間
month_arr = Array(10, 11, 12, 10, 1, 2, 3, 1, 10, 4, 5, 6, 4, 7, 8, 9, 7, 4, 10)
month_flg = Array(0)
ReDim month_flg(UBound(month_arr))
Dim i As Long
Dim smm As Long 'テーブル内の各月
Dim tmm As Long '到来月
tmm = arv_month
If tmm < 10 Then tmm = tmm + 12
For i = 0 To UBound(month_arr)
smm = month_arr(i)
If smm < 10 Then smm = smm + 12
If smm > tmm Then
month_flg(i) = False
Else
month_flg(i) = True
End If
Next
End Sub
'順位表シートクリア
Private Sub sheet_clear(ByVal ws As Worksheet)
Dim i As Long
Dim scol As Long
Dim wrow As Long
For i = 0 To UBound(month_flg)
Dim maxrow As Long
maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'A列最大行取得
For wrow = 5 To maxrow
scol = get_trg_col_by_index(i)
ws.Cells(wrow, scol + 1).Value = "" 'エリア／支店
ws.Cells(wrow, scol + 2).Value = "" '粗利計画
ws.Cells(wrow, scol + 3).Value = "" '粗利実績
ws.Cells(wrow, scol + 4).Value = "" '達成率対計画金額
ws.Cells(wrow, scol + 5).Value = "" '伸長額対計画金額
Next
Next
End Sub
'月のindexから先頭のカラム位置を取得（順位シート）
Private Function get_trg_col_by_index(ByVal mx As Long)
get_trg_col_by_index = 1 + mx * 6
End Function
'月のindexから先頭のカラム位置を取得（作業シート）
Private Function get_work_col_by_index(ByVal mx As Long)
get_work_col_by_index = 1 + mx * 5
End Function
'月のindexから先頭のカラム位置を取得（元データファイルのシート）
Private Function get_src_col_by_index(ByVal mx As Long)
get_src_col_by_index = 3 + mx * 23
End Function
'カラム番号を文字に変換する
Public Function ConvertToLetter(ByVal iCol As Long) As String
Dim iAlpha As Long
Dim iRemainder As Long
iAlpha = Int((iCol - 1) / 26)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function
'月フラグの印字（デバッグ確認用）
Private Sub dump_flag(ByVal month_flg As Variant)
Dim i As Long
For i = 0 To UBound(month_flg)
Debug.Print "i=" & i & " " & month_flg(i)
Next
End Sub
your text goes here
