|
ありがとうございます。
こちらの方がスマートかと思い、
実際にやってみましたが
下の様になってしまいました。
参照している部分がおかしいとは
思えないのですが・・・。
Sub 営業所別集計_保存()
Dim SAry As Variant, TAry As Variant
Dim Ary1 As Variant, Ary2 As Variant
Dim Snm As String, NewB As String
Dim i As Integer, Ans As Integer
SAry = Array("SZ_A", "SZ_B", "SZ_C", "5Z", "3Z", "KZ")
TAry = Array("NEIG", "K_NEIG", "JK8", "JK9", "JK10")
Ary1 = Array("01", "02", "03", "04", "05", _
"0A", "0B", "0C", "0D", "総計")
Ary2 = Array("東北", "関西", "北海道", "九州", _
"広島", "島根", "鳥取", "東京", "沖縄")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Worksheets.Add Before:=Worksheets(1), Count:=6
With Worksheets(1)
.Range("A1:E1").Value = TAry
With .Range("A2:A11")
.NumberFormat = "@"
.Value = WorksheetFunction.Transpose(Ary1)
End With
.Range("B2:B10").Value = WorksheetFunction _
.Transpose(Ary2)
Sheets(Array(1, 2, 3, 4, 5, 6)) _
.FillAcrossSheets .Range("A1:E11")
End With
For i = 6 To 1 Step -1
Snm = SAry(i - 1) & "集計"
NewB = ThisWorkbook.Path & "\" & Snm & _
Format(Date, "yymmdd") & ".xls"
If Dir(NewB) <> "" Then
Ans = MsgBox(Snm & ".xls は本日分を作成済みです。" & _
vbLf "ファイルを削除して再度作成しますか", 36)
If Ans = 6 Then
Kill NewB
ElseIf Ans = 7 Then
Worksheets(i).Delete: GoTo NLine
End If
End If
With Worksheets(i)
.Name = Snm
Fom = "=SUMIF(" & SAry(i - 1) & "!$C:$C,$A2," & _
SAry(i - 1) & "!L:L)"
.Range("C2:E10").Formula = Fom
.Range("C11:E11").Formula = "=SUM(C$2:C$10)"
With .Range("C2:E11")
.Value = .Value
End With
.Move
End With
ActiveWorkbook.Close True, NewB
NLine:
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "本日の集計ブック作成は完了しました", 64
End Sub
6つのファイル全てがこの様な結果です。
NEIG K_NEIG JK8 JK9 JK10
01 東北 #VALUE! #VALUE! #VALUE!
02 関西 #VALUE! #VALUE! #VALUE!
03 北海道 #VALUE! #VALUE! #VALUE!
04 九州 #VALUE! #VALUE! #VALUE!
05 広島 #VALUE! #VALUE! #VALUE!
0A 島根 #VALUE! #VALUE! #VALUE!
0B 鳥取 #VALUE! #VALUE! #VALUE!
0C 東京 #VALUE! #VALUE! #VALUE!
0D 沖縄 #VALUE! #VALUE! #VALUE!
総計 #VALUE! #VALUE! #VALUE!
|
|