| |
>下の様になってしまいました。
こちらで実際にテストすることは殆ど不可能なので、成功した方のコードを
改造して、不要な列(A:B,D:K)を削除するようにしてみました。
Sub 営業所別集計_保存()
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_AA", "SZ_AB", "SZ_AC", "3Z", "5Z", "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).Range("A1:T1").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 & ".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,$C2," & _
SAry(i - 1) & "!L:L)"
.Range("L2:T10").Formula = Fom
.Range("L11:T11").Formula = "=SUM(L$2:L$10)"
With .Range("L2:T11")
.Value = .Value
End With
.Range("A:B, E:K").Delete xlShiftToLeft
.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/19(木) 12:08 -
