| |
先ほどのコードでは一行目の項目がずれてしまうので、修正しました。
今度は"必要と思われる項目・データ・集計値のみ"を、A1から詰めて
入力する形にしています。こちらでテストしてみて下さい。
Sub Mk_DataTotalBook_2()
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 = 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
|
|
Kein
- 06/10/18(水) 17:15 -
