Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6716 / 13646 ツリー ←次へ | 前へ→

【43514】集計(かなり複雑です) 06/10/18(水) 15:06 質問[未読]
【43517】Re:集計(かなり複雑です) Kein 06/10/18(水) 16:59 回答[未読]
【43518】Re:集計(かなり複雑です) Kein 06/10/18(水) 17:15 回答[未読]
【43521】Re:集計(かなり複雑です) Kein 06/10/18(水) 17:57 発言[未読]
【43552】Re:集計(かなり複雑です) 06/10/19(木) 10:32 質問[未読]
【43567】Re:集計(かなり複雑です) Kein 06/10/19(木) 12:08 回答[未読]
【43572】Re:集計(かなり複雑です) 06/10/19(木) 12:48 お礼[未読]
【43580】Re:集計(かなり複雑です) 06/10/19(木) 14:15 質問[未読]
【43581】Re:集計(かなり複雑です) Kein 06/10/19(木) 14:41 発言[未読]
【43549】Re:集計(かなり複雑です) 06/10/19(木) 10:16 お礼[未読]

【43514】集計(かなり複雑です)
質問    - 06/10/18(水) 15:06 -

引用なし
パスワード
   下記のようなDBがあります。
全てのフィールドはスペースの関係上、入力できなかったのですが。
1つのブック内に6枚のシートに分けて(6つの商品があるので)
保存されています。6枚のシート名(SZ_A,SZ_B,SZ_C,5Z,3Z,KZ)。
そのシートの内容が下記↓のようなDBです。

A    B    C    D  ・・・  L    M    N

PCG    PCGK    NEIG    K_NEIG    JK8    JK9    JK10
05    輸出    0B    鳥取    302    250    150
04    輸入    03    北海道    12    20    10
05    輸出    0B    鳥取    550    700    700
05    輸出    0A    島根    70    70    70
05    輸出    01    東北    10    11    10
05    輸出    0B    鳥取    650    600    400
05    輸出    0D    沖縄    147    200    200

ここで何がしたいかというと結論下記↓の様な結果を出したいです。

PCG    PCGK    NEIG    K_NEIG    JK8    JK9    JK10
        01 集計    東北    10    11    10
        02 集計    関西    0    0    0
        03 集計    北海道    12    20    10
        04 集計    九州    0    0    0
        05 集計    広島    0    0    0
        0A 集計    島根    70    70    70
        0B 集計    鳥取    1502    1550    1250
        0C 集計    東京    0    0    0
        0D 集計    沖縄    147    200    200
        総計        1741    1851    1540

具体的には
1.まず、C列(フィールド名:NEIG)ごとにL列〜N列の合計を集計したい。
ここでぶつかる壁があります。C列には"01,02,03,04,05,0A,0B,0C,0D"9種類の
得意先がある。L列〜N列の値がゼロで合っても結果として9行の集計行+総計行
が必要。また結果として小計行を9行並べた時に得意先の並びは
決して変更したくない。
並びはこの通り上から"01,02,03,04,05,0A,0B,0C,0D"
例えば、C2に必ず01集計がきてC10には0D集計がくる。
また集計結果はL2を基点に表示。
C列とL列〜N列以外にデータは不要。

2.6つの商品シートごとに各1.の操作が出来たら、それを新規ブックに保存し、
マクロを含むブックと同じフォルダに保存する。
6つの新規ブックが出来上がる。ファイル名は商品シート名と同じにする。

3.もうひとつの壁。6枚の商品ごとのシートには1件もレコードがない場合もある。
その場合でも。シートは作成する。下記↓の様になる。

PCG    PCGK    NEIG    K_NEIG    JK8    JK9    JK10
        01 集計    東北    0    0    0
        02 集計    関西    0    0    0
        03 集計    北海道    0    0    0
        04 集計    九州    0    0    0
        05 集計    広島    0    0    0
        0A 集計    島根    0    0    0
        0B 集計    鳥取    0    0    0
        0C 集計    東京    0    0    0
        0D 集計    沖縄    0    0    0
        総計        0    0    0

自動集計するだけでなく、表示位置、並びなど条件が多すぎてどこから
手を付けてよいのかなやんでいます。
シンプルに出来る方法はありますでしょうか?

【43517】Re:集計(かなり複雑です)
回答  Kein  - 06/10/18(水) 16:59 -

引用なし
パスワード
   殆どベタ書きなので、うまくいくかどうか分かりませんが、以下のような
コードでどうでしょーか ? ファイル名には作成した年月日を入れてます。
それにより、重複して作成するのをチェックできます。

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    

【43518】Re:集計(かなり複雑です)
回答  Kein  - 06/10/18(水) 17:15 -

引用なし
パスワード
   先ほどのコードでは一行目の項目がずれてしまうので、修正しました。
今度は"必要と思われる項目・データ・集計値のみ"を、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

【43521】Re:集計(かなり複雑です)
発言  Kein  - 06/10/18(水) 17:57 -

引用なし
パスワード
   さらに部分的な修正個所がありました。

   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

というように、If Ans = ・・のところを変更して下さい。
たびたびすいません。

【43549】Re:集計(かなり複雑です)
お礼    - 06/10/19(木) 10:16 -

引用なし
パスワード
   ありがとうございます。
集計値をL列にセットするような形にしました。
修正しやすく、分かりやすかったです。
こういう風に教えてもらうとかなり勉強になりました。

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).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 & ".xls"          If Dir(NewB) <> "" Then
     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("L2:T10").Formula = Fom                   'どの列に集計を配置するか指定。
     .Range("L11:T11").Formula = "=SUM(L$2:L$10)"         '総計L〜T列11行目
     With .Range("L2:T11")
      .Value = .Value
     End With
     .Move
   End With
   ActiveWorkbook.Close True, NewB
NLine:
  Next i
  With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
  End With

End Sub

【43552】Re:集計(かなり複雑です)
質問    - 06/10/19(木) 10:32 -

引用なし
パスワード
   ありがとうございます。
こちらの方がスマートかと思い、
実際にやってみましたが
下の様になってしまいました。
参照している部分がおかしいとは
思えないのですが・・・。
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!

【43567】Re:集計(かなり複雑です)
回答  Kein  - 06/10/19(木) 12:08 -

引用なし
パスワード
   >下の様になってしまいました。
こちらで実際にテストすることは殆ど不可能なので、成功した方のコードを
改造して、不要な列(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

【43572】Re:集計(かなり複雑です)
お礼    - 06/10/19(木) 12:48 -

引用なし
パスワード
   本当にありがとうございます。
うまくいきました。
やはり、列をつめて集計結果を作成したほうが
後々使いやすいのでこちらのパターンにしました。
ありがとうございました。

【43580】Re:集計(かなり複雑です)
質問    - 06/10/19(木) 14:15 -

引用なし
パスワード
   出来上がった6つのファイルを開いてみたところ、
指定している範囲が選択された状態でした。
出来上がった6つのファイルですが、
保存する際にA1をSelectするようには
出来ないでしょうか?

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
  .Move
  Range("A1").Select '||||||||ここに一文入れたのですが(ToT)/だめでした
End With
   ActiveWorkbook.Close True, NewB
NLine:
  Next i
  With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
  End With

End Sub

【43581】Re:集計(かなり複雑です)
発言  Kein  - 06/10/19(木) 14:41 -

引用なし
パスワード
   Moveメソッドが実行されると、該当のシートは新規ブックになってしまいます。
従って、A1を選択するコードを入れるなら Move の前にしないといけません。

With Worksheets(i)
  .Activate '←セルを選択するなら、必ずそのシートを開く必要があります。
  .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
  .Range("A1").Select
  .Move
End With

6716 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free