Option Explicit
Dim month_flg As Variant '到来月対応編集フラグ
Public Sub 最優秀個人数量売上2()
Dim ws As Worksheet '管理シート
Dim kj_ws As Worksheet '個人別順位シート
Dim folder As String 'フォルダー名
Dim bname As String '元データファイル名
Dim sname As String '元データファイルのシート名
Dim full_bname As String '元データファイル名フルパス
Dim arv_month As Variant '到来月
Dim srcbook As Workbook '元データブック
Dim src_ws As Worksheet '元データブックのシート
Dim i As Long
Dim num_array As Variant '通番
Dim col_array As Variant '数量売上実績の相対列(0オリジン)
Dim trgname As String
num_array = Array("①", "②", "③", "④", "⑤", "⑥")
col_array = Array(2, 2, 3, 2, 3, 3)
Set ws = Worksheets("管理")
folder = ws.Cells(3, "B").Value
bname = ws.Cells(3, "C").Value
sname = ws.Cells(3, "D").Value
arv_month = ws.Cells(3, "E").Value
'入力パラメータチェック
Call CheckParams(folder, bname, arv_month, full_bname)
If sname = "" Then
MsgBox ("シート名エラー")
Exit Sub
End If
If MsgBox("個人別順位シート①~⑥を作成します", vbOKCancel) <> vbOK Then
Exit Sub
End If
Call set_month_flag(arv_month, month_flg)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'元データファイルのオープン
Set srcbook = Workbooks.Open(full_bname)
If check_sheet_name(sname) = False Then
MsgBox ("シート名エラー(" & sname & ")は" & bname & "に存在しません")
srcbook.Close
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
Set src_ws = Worksheets(sname)
For i = 0 To UBound(num_array)
trgname = "個人別" & num_array(i)
Set kj_ws = ThisWorkbook.Worksheets(trgname)
'抽出先シートクリア
Call sheet_clear(kj_ws)
'順位作成
Call sheet_rank(kj_ws, src_ws, srcbook, num_array(i), col_array(i))
Next
'元データファイルのクローズ
srcbook.Close
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox ("完了")
End Sub
'順位シートの設定
Private Sub sheet_rank(ByVal kj_ws As Worksheet, ByVal src_ws As Worksheet, ByVal wbook As Workbook, ByVal num As String, ByVal rel_col As Long)
Dim wn1 As String '作業シート名①
Dim wk1 As Worksheet '作業シート①
Dim edt_row As Long '元データの各人対応の編集行
Dim src_col As Long '元データの月インデックス対応の開始カラム位置
Dim i As Long
Dim ps As Long
Dim wk_row As Long '作業シートの行番号
Dim wk_col As Long '作業シートの月インデックス対応の開始カラム位置
Dim maxrow As Long '元データのG列最終行
Dim maxps As Long '最大担当者数
ThisWorkbook.Activate
wn1 = "作業①"
Set wk1 = Worksheets(wn1)
wk1.Cells.ClearContents
wbook.Activate
maxrow = src_ws.Cells(Rows.Count, "G").End(xlUp).Row 'sheetのG列最大行取得
If maxrow < 34 Or ((maxrow - 3) Mod 31) <> 0 Then
MsgBox ("元データG列の最終行不正")
src_ws.Cells(maxrow, "G").Select
Application.Calculation = xlCalculationAutomatic
End
End If
maxps = (maxrow - 3) \ 31
wk_row = 0
'人数分繰り返す
For ps = 1 To maxps
edt_row = GetRowNo(ps, src_ws, num) '抽出対象の行を取得
'抽出対象の行があった場合、処理する
If edt_row <> 0 Then
wk_row = wk_row + 1
'全月分繰り返す
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(edt_row, src_col + rel_col).Value) = False Then
MsgBox ("数量売上不正")
src_ws.Cells(edt_row, src_col + rel_col).Select
Application.Calculation = xlCalculationAutomatic
End
End If
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col).Value = src_ws.Cells(edt_row, "B").Value '拠点
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 1).Value = src_ws.Cells(edt_row, "C").Value '課
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 2).Value = src_ws.Cells(edt_row, "D").Value '担当者
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 3).Value = src_ws.Cells(edt_row, src_col + 1).Value
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 4).Value = src_ws.Cells(edt_row, src_col + 5).Value
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 5).Value = src_ws.Cells(edt_row, src_col + 7).Value
'対計画達成/未達成額 追加開始20190311
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 6).Value = _
ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 4).Value - ThisWorkbook.Worksheets(wn1).Cells(wk_row, wk_col + 3).Value
'対計画達成/未達成額 追加終了20190311
End If
Next
End If
Next
ThisWorkbook.Activate
Call sheet_rank_div(kj_ws, wk1, wk_row) '個人別の順位設定
End Sub
'抽出対象の行番号を求める
'ps:担当者の番号(1~99)
Private Function GetRowNo(ByVal ps As Long, ByVal src_ws As Worksheet, ByVal num As String)
Dim str_row As Long
Dim wrow As Long
Dim goukei As String
goukei = num & "合計"
str_row = (ps - 1) * 31 + 4
For wrow = str_row To (str_row + 30)
'支店/課/担当者/合計が空白でないなら処理する
'修正2013.03.18
If src_ws.Cells(wrow, "B").Value <> "" And src_ws.Cells(wrow, "C").Value <> "" And src_ws.Cells(wrow, "D").Value <> "" And src_ws.Cells(wrow, "F").Value = goukei Then
GetRowNo = wrow
Exit Function
End If
Next
GetRowNo = 0
End Function
'個人別の順位シートの設定
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 + 6) '修正20190311
keycol = ConvertToLetter(wk_col + 6) '修正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 '数量売上実績
ws.Cells(wk_row + 4, tr_col + 6).Value = wk.Cells(wk_row, wk_col + 5).Value '対計画達成率
ws.Cells(wk_row + 4, tr_col + 7).Value = wk.Cells(wk_row, wk_col + 6).Value '対計画達成/未達成額 追加20190311
Next
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
Dim maxrow As Long
maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'A列最大行取得
For i = 0 To UBound(month_flg)
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 = "" '数量売上実績
ws.Cells(wrow, scol + 6).Value = "" '対計画達成率
ws.Cells(wrow, scol + 7).Value = "" '対計画達成/未達成額 追加20190311
Next
Next
End Sub
'月のindexから先頭のカラム位置を取得(順位シート)
Private Function get_trg_col_by_index(ByVal mx As Long)
get_trg_col_by_index = 1 + mx * 8
End Function
'月のindexから先頭のカラム位置を取得(作業シート)
Private Function get_work_col_by_index(ByVal mx As Long)
get_work_col_by_index = 1 + mx * 7 '修正20190311
End Function
'月のindexから先頭のカラム位置を取得(元データファイルのシート)
Private Function get_src_col_by_index(ByVal mx As Long)
get_src_col_by_index = 7 + mx * 8
End Function