Option Explicit
Sub 数値代入(カテゴリ As Variant, フラグ As Variant, 範囲 As Variant, 対象列 As Integer)
Dim i As Integer, j As Integer, k As Integer, sRange As Range, sName As String
'該当月に関数代入（PJPLをSUMIFする）
Workbooks(カテゴリ).Activate
If フラグ = 1 Then
j = 7
Else
j = 3
End If
'「○」から「●」までのシートで関数代入～値化～合計関数戻し
For i = j To Worksheets.Count - 1
Worksheets(i).Activate
With Worksheets(i)
'※$ZZ$8は十分値により修正の可能性有
.Cells(4, 対象列).Formula = "=SUMIF(" & 範囲 & "!$C$6:$ZZ$6,$B$2," & 範囲 & "!$C8:$ZZ8)"
.Cells(4, 対象列).Copy
.Range(Cells(4, 対象列), Cells(108, 対象列)).PasteSpecial Paste:=xlFormulas
.Range(Cells(4, 対象列), Cells(108, 対象列)).Copy
.Range(Cells(4, 対象列), Cells(108, 対象列)).PasteSpecial Paste:=xlValues
End With
For k = 1 To 105
Select Case k
Case 12, 16, 29, 49, 53, 54, 55, 62, 67, 80, 81, 86, 89, 92, 93, 96, 100, 101, 105
Cells(k + 3, 対象列).Select
Selection.FillRight
End Select
Next
'カーソルをA1セルに移動
Range("A1").Select
Next
Worksheets.Add(Before:=Worksheets(1)).Name = "temp"
For i = j + 1 To Worksheets.Count - 1
Cells(i, 1) = Worksheets(i).Name
Next
Set sRange = Cells(j + 1, 1).CurrentRegion
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Cells(j + 1, 1), SortOn:=xlSortOnValues, Order:=xlAscending
.SetRange sRange
.Apply
End With
For i = 1 To sRange.Rows.Count
sName = Worksheets("temp").Cells(i + j, 1)
Worksheets(sName).Move after:=Worksheets(i + j - 1)
Next
Application.DisplayAlerts = False
Worksheets("temp").Delete
Application.DisplayAlerts = True
End Sub
Sub グループ判定(GP As String, FILE As String, AM1部 As String, AM2部 As String, MM室 As String, IMS合計 As String)
If GP = "ｱｶｳﾝﾄﾏﾈｼﾞﾒﾝﾄ1部" Then
FILE = AM1部
ElseIf GP = "ｱｶｳﾝﾄﾏﾈｼﾞﾒﾝﾄ2部" Then
FLE = AM2部
ElseIf GP = "ﾒﾃﾞｨｱﾏｰｹﾃｨﾝｸﾞ室" Then
FILE = MM室
Else
FILE = IMS合計
End If
End Sub
Sub BtoB_PJPL作成マクロ()
'エラーの際は「エラー処理」へ
On Error GoTo エラー処理
'変数定義
Dim SHEET_元帳 As Variant, SHEET_ピボット As Variant, SHEET_PJ列別PL As Variant
Dim SHEET_存在判定 As Variant, SHEET_追記用PL As Variant, SHEET_ST管理表 As Variant
Dim FILE_AM1部 As Variant, FILE_AM2部 As Variant, FILE_MM室 As Variant, FILE_IMS合計 As Variant, FILE_MACRO As Variant
Dim ARRAY_追記ラベル As Variant
Dim RANGE_ピボット As Variant, RANGE_ST管理表 As Variant, PATH_PJ列別PL_外部用 As Variant, PATH_データ格納 As Variant
Dim COUNT_PJ As Variant, COUNT_行 As Variant, COLUMN_ST管理表 As Variant
Dim COUNT_NEWPJ As Variant, SHEET_NEWPJPL As Variant, START_NEWPJ As Variant, END_NEWPJ As Variant
Dim i As Variant, j As Variant, COLUMN_MONTH As Integer
Dim xPCach As PivotCache, xPTbl As PivotTable
Dim BEFORE_GP As String, AFTER_GP As String, JUDGE_GP As String
Dim BEFORE_FILE As String, AFTER_FILE As String, FILE As String
'名称代入
SHEET_元帳 = "元帳"
SHEET_ピボット = "ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ"
SHEET_PJ列別PL = "PJPL"
SHEET_存在判定 = "存在シート判定"
SHEET_追記用PL = "追記用PL"
SHEET_ST管理表 = Worksheets(Worksheets.Count).Name
FILE_AM1部 = "ｱｶｳﾝﾄﾏﾈｼﾞﾒﾝﾄ1部.xlsx"
FILE_AM2部 = "ｱｶｳﾝﾄﾏﾈｼﾞﾒﾝﾄ2部.xlsx"
FILE_MM室 = "ﾒﾃﾞｨｱﾏｰｹﾃｨﾝｸﾞ室.xlsx"
FILE_IMS合計 = "IMS事業部(BtoB)合計.xlsx"
FILE_MACRO = ActiveWorkbook.Name
ARRAY_追記ラベル = Array("事業部ｺｰﾄﾞ", "事業部", "部室ｺｰﾄﾞ", "部室名", "ｸﾞﾙｰﾌﾟｺｰﾄﾞ", "ｸﾞﾙｰﾌﾟ名")
PATH_データ格納 = ActiveWorkbook.Path
PATH_PJ列別PL_外部用 = "[" & FILE_MACRO & "]" & SHEET_PJ列別PL
'変数の値代入
COUNT_行 = Worksheets(SHEET_元帳).Range("A1").End(xlDown).Row
'※$AG$2000は十分値により修正の可能性有
RANGE_ST管理表 = "'" & SHEET_ST管理表 & "'!$A$12:$AG$2000"
COLUMN_MONTH = Range("L3").Value
COLUMN_ST管理表 = Range("I4").Value
'各種ファイルオープン（AM1・AM2・MM・合計）⇒マクロシートに戻す
Workbooks.Open PATH_データ格納 & "\" & FILE_AM1部
Workbooks.Open PATH_データ格納 & "\" & FILE_AM2部
Workbooks.Open PATH_データ格納 & "\" & FILE_MM室
Workbooks.Open PATH_データ格納 & "\" & FILE_IMS合計
Workbooks(FILE_MACRO).Activate
'//--元帳操作
With Worksheets(SHEET_元帳)
.Activate
.Range("Q1").Value = ARRAY_追記ラベル(0)
.Range("R1").Value = ARRAY_追記ラベル(1)
.Range("S1").Value = ARRAY_追記ラベル(2)
.Range("T1").Value = ARRAY_追記ラベル(3)
.Range("U1").Value = ARRAY_追記ラベル(4)
.Range("V1").Value = ARRAY_追記ラベル(5)
.Range("Q2").Formula = "=VLOOKUP($K2," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & "-5,0)"
.Range("R2").Formula = "=VLOOKUP($K2," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & "-4,0)"
.Range("S2").Formula = "=VLOOKUP($K2," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & "-3,0)"
.Range("T2").Formula = "=VLOOKUP($K2," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & "-2,0)"
.Range("U2").Formula = "=VLOOKUP($K2," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & "-1,0)"
.Range("V2").Formula = "=VLOOKUP($K2," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & ",0)"
.Range("Q2:V2").Copy
.Paste Range(.Range("Q2"), .Cells(COUNT_行, 17))
End With
Set RANGE_ピボット = Worksheets(SHEET_元帳).Range("A1", Cells(COUNT_行, "V")) '範囲設定
Worksheets.Add Before:=Worksheets(SHEET_元帳)
ActiveSheet.Name = SHEET_ピボット
'//--ピボットテーブル作成
'①ピボットキャッシュ作成
Set xPCach = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=RANGE_ピボット)
'②ピボットキャッシュを元にピボットテーブルを作成
Set xPTbl = xPCach.CreatePivotTable _
(TableDestination:=Range("A3"), TableName:="Pivot1")
'③ピボットテーブルの行・列・値などにフィールドを配置
With ActiveSheet.PivotTables("Pivot1")
'行フィールド設定
.AddFields RowFields:=Array("PL番号", "PL科目")
'列フィールド設定
With .PivotFields("プロジェクトコード")
.Orientation = xlColumnField
.Position = 1
End With
With .PivotFields("プロジェクト名称")
.Orientation = xlColumnField
.Position = 2
End With
'データフィールド設定
With .PivotFields("金額")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0_ "
End With
'集計行非表示
.PivotFields("PL番号").Subtotals(1) = False
.PivotFields("プロジェクトコード").Subtotals(1) = False
.InGridDropZones = True
.RowAxisLayout xlTabularRow
End With
ActiveSheet.Range("C6").Select
ActiveWindow.FreezePanes = True
'//--PJPLシート追加～PJコードペースト
Worksheets.Add Before:=Worksheets(SHEET_ピボット)
ActiveSheet.Name = SHEET_PJ列別PL
Worksheets(1).Activate
ActiveSheet.Range("B8", "D117").Copy
ActiveSheet.Paste Worksheets(SHEET_PJ列別PL).Range("A3")
Worksheets(SHEET_PJ列別PL).Range("A:B").Columns.AutoFit
With Worksheets(SHEET_ピボット)
.Activate
COUNT_PJ = .Range("A5").End(xlToRight).Column
.Range("C4", Cells(5, COUNT_PJ)).Copy
.Paste Worksheets(SHEET_PJ列別PL).Range("C6")
.Range("C8").Select
' Worksheets(SHEET_ピボット).Activate
' COUNT_PJ = ActiveSheet.Range("A5").End(xlToRight).Column
' ActiveSheet.Range("C4", Cells(5, COUNT_PJ)).Copy
' ActiveSheet.Paste Worksheets(SHEET_PJ列別PL).Range("C6")
End With
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 85
'//--関数代入～PJPL全体の完成（関数のまま）※Case文使う方がわかりやすい
With Worksheets(SHEET_PJ列別PL)
'※$ZZ$50は十分値により修正の可能性有
.Activate
.Range("C8").Formula = "=IF(ISERROR(MATCH($A8,ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ!$A$6:$A$100,0)),0,INDEX(ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ!$C$6:$ZZ$100,MATCH($A8,ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ!$A$6:$A$100,0),MATCH(C$6,ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ!$C$4:$ZZ$4,0)))"
.Range("C8").Copy
For i = 1 To 105
Select Case i
Case 12, 16, 29, 49, 53, 54, 55, 62, 67, 80, 81, 86, 89, 92, 93, 96, 100, 101, 105
Case Else
.Paste Cells(i + 7, "C")
End Select
Next
.Range("C8", "C112").Copy
.Paste Range(.Range("C8"), .Cells(112, COUNT_PJ))
End With
'//--存在シート判定
'※6月作成後、起点セル変更H3⇒I3 2011/7/14
Worksheets(SHEET_ピボット).Activate
COUNT_PJ = ActiveSheet.Range("A5").End(xlToRight).Column
ActiveSheet.Range("C4", Cells(5, COUNT_PJ)).Copy
With Worksheets(SHEET_存在判定)
.Activate
.Range("I3").PasteSpecial Paste:=xlValues, Transpose:=True
COUNT_PJ = .Range("I3").End(xlDown).Row
START_NEWPJ = .Range("B3").End(xlDown).Row + 1
END_NEWPJ = START_NEWPJ
'※$B$1000は十分値により修正の可能性有
.Range("K3").Formula = "=IF(ISERROR(VLOOKUP($I3,$B$3:$B$1000,1,0)),""NG"",""OK"")"
.Range("K3").Copy
.Paste Range(.Range("K3"), .Cells(COUNT_PJ, "K"))
For i = 3 To COUNT_PJ
If .Cells(i, "K").Value = "NG" Then
COUNT_NEWPJ = .Range("B3").End(xlDown).Row + 1
.Range(.Cells(i, "I"), .Cells(i, "J")).Copy
.Cells(COUNT_NEWPJ, "B").PasteSpecial Paste:=xlValues
.Cells(COUNT_NEWPJ, "D").Formula = "=SUBSTITUTE(LEFTB(CONCATENATE(IF(B" & COUNT_NEWPJ & ">=1000,B" & COUNT_NEWPJ & ",0&B" & COUNT_NEWPJ & "),C" & COUNT_NEWPJ & "),30),""/"","" "")"
.Cells(COUNT_NEWPJ, "E").Formula = "=VLOOKUP($B" & COUNT_NEWPJ & "," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & ",0)"
END_NEWPJ = END_NEWPJ + 1
End If
Next
.Range("F3").Formula = "=VLOOKUP($B3," & RANGE_ST管理表 & "," & COLUMN_ST管理表 & ",0)"
.Range("G3").Formula = "=IF($E3=$F3,""OK"",""NG"")"
.Range("F3", "G3").Copy
.Paste Range(.Range("F3"), .Cells(END_NEWPJ - 1, "F"))
End With
'//--新規PJのPLシート追加
'テスト用
' START_NEWPJ = 225
' END_NEWPJ = 226
'新規PJPLに関する情報を追記用PLに代入
For j = START_NEWPJ To END_NEWPJ - 1
With Worksheets(SHEET_追記用PL)
.Range("B2") = Worksheets(SHEET_存在判定).Cells(j, "B").Value
.Range("E2") = Worksheets(SHEET_存在判定).Cells(j, "C").Value
SHEET_NEWPJPL = Worksheets(SHEET_存在判定).Cells(j, "D").Value
JUDGE_GP = Worksheets(SHEET_存在判定).Cells(j, "E").Value
'グループ判定
グループ判定 JUDGE_GP, FILE, FILE_AM1部, FILE_AM2部, FILE_MM室, FILE_IMS合計
If JUDGE_GP = "ｱｶｳﾝﾄﾏﾈｼﾞﾒﾝﾄ1部" Then
FILE_追記 = FILE_AM1部
ElseIf JUDGE_GP = "ｱｶｳﾝﾄﾏﾈｼﾞﾒﾝﾄ2部" Then
FILE_追記 = FILE_AM2部
ElseIf JUDGE_GP = "ﾒﾃﾞｨｱﾏｰｹﾃｨﾝｸﾞ室" Then
FILE_追記 = FILE_MM室
Else
FILE_追記 = FILE_IMS合計
End If
'新規PJPL追加
.Copy Before:=Workbooks(FILE_追記).Worksheets("●")
End With
'シート名を変更して、マクロシートに戻る
ActiveSheet.Name = SHEET_NEWPJPL
Workbooks(FILE_MACRO).Activate
Next
'PJの部門が変更になったシートを移動させる
With Worksheets(SHEET_存在判定)
For j = 3 To START_NEWPJ - 1
If Cells(j, "G") = "NG" Then
BEFORE_GP = .Cells(j, "E").Value
AFTER_GP = .Cells(j, "F").Value
グループ判定 BEFORE_GP, BEFORE_FILE, FILE_AM1部, FILE_AM2部, FILE_MM室, FILE_IMS合計
グループ判定 AFTER_GP, AFTER_FILE, FILE_AM1部, FILE_AM2部, FILE_MM室, FILE_IMS合計
'BEFOREファイル呼び出し
'該当シート捜索
'AFTERシートに移動
'//--各データで数値代入※合計データのみフラグ「1」を立てる
数値代入 FILE_AM1部, 0, PATH_PJ列別PL_外部用, COLUMN_MONTH
数値代入 FILE_AM2部, 0, PATH_PJ列別PL_外部用, COLUMN_MONTH
数値代入 FILE_MM室, 0, PATH_PJ列別PL_外部用, COLUMN_MONTH
数値代入 FILE_IMS合計, 1, PATH_PJ列別PL_外部用, COLUMN_MONTH
'//--IMS合計の総計PL金額とマクロのPJ列別PLの各行合計と一致するか確認する
With Workbooks(FILE_MACRO).Worksheets(SHEET_PJ列別PL)
.Activate
COUNT_PJ = .Range("A7").End(xlToRight).Column
.Cells(7, COUNT_PJ + 1).Value = "PJ合計"
.Cells(7, COUNT_PJ + 2).Value = "IMS合計PLより"
.Cells(7, COUNT_PJ + 3).Value = "差異"
.Cells(8, COUNT_PJ + 1).Formula = "=SUM(C8：" & Cells(8, COUNT_PJ).Address(0, 0) & ")"
.Cells(8, COUNT_PJ + 3).Formula = "=" & Cells(8, COUNT_PJ + 2).Address(0, 0) & "-" & Cells(8, COUNT_PJ + 1).Address(0, 0)
.Range(Cells(8, COUNT_PJ + 1), Cells(8, COUNT_PJ + 3)).Copy
.Paste Range(Cells(8, COUNT_PJ + 1), Cells(112, COUNT_PJ + 1))
End With
Workbooks(FILE_IMS合計).Worksheets(1).Activate
Range(Cells(4, COLUMN_MONTH), Cells(108, COLUMN_MONTH)).Copy
Workbooks(FILE_MACRO).Worksheets(SHEET_PJ列別PL).Activate
ActiveSheet.Cells(8, COUNT_PJ + 2).PasteSpecial Paste:=xlValues
Exit Sub
'エラー発生時の処理
エラー処理:
MsgBox Err.Number & ":" & Err.Description
End Sub
最終更新：2011年08月02日 10:57
