| |
殆どベタ書きなので、うまくいくかどうか分かりませんが、以下のような
コードでどうでしょーか ? ファイル名には作成した年月日を入れてます。
それにより、重複して作成するのをチェックできます。
Sub Mk_DataTotalBook()
Dim SAry As Variant, 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")
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)
Worksheets(7).Rows(1).Copy .Range("A1")
With .Range("C2:C11")
.NumberFormat = "@"
.Value = WorksheetFunction.Transpose(Ary1)
End With
.Range("D2:D10").Value = WorksheetFunction _
.Transpose(Ary2)
Sheets(Array(1, 2, 3, 4, 5, 6)) _
.FillAcrossSheets .Range("A1:IV11")
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 = 7 Then
Worksheets(i).Delete: GoTo NLine
End If
End If
With Worksheets(i)
.Name = Snm
Fom = "=SUMIF(" & SAry(i - 1) & "!$C:$C,$C2," & _
SAry(i - 1) & "!L:L)"
.Range("E2:G10").Formula = Fom
.Range("E11:G11").Formula = "=SUM(E$2:E$10)"
With .Range("E2:G11")
.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
|
|
Kein
- 06/10/18(水) 16:59 -
