[[20120601100318]]　『複数ブック、シートの特定のセル（行）を別の1つａx（まんぷく）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『複数ブック、シートの特定のセル（行）を別の1つのブックに集約』（まんぷく）

Excel2007
Windows Vista

ある製品の検品の日ごとの集計を行うため
検品チーム（A～E）毎に集計をとっております。
１チームで１つのブック（ブック名は検品A.xls～検品E.xls）
で管理しており、その中に検品した製品毎に同じ雛形でシート別
（シート名は①～⑩※10種類ある場合。日によって製品・数は違うが
番号と製品はチームで統一）で分けて管理しております。

1日の終わりに各チーム毎のPCで入力して貰った
ブック（検品*.xls）を集めてデスクトップ上のデータ置き場フォルダに格納します。

デスクトップ上に集計.xlsという別のブックを用意して
中のシートに予め容易された集計ボタンなどを押したら
製品毎（シート名は対応した同じ①～⑩）にシート別に分けて
各チームのブックの各シートにある総数・良品・各不良項目の合計値が
記入されているセル（行）の値のみを集計ブックの各製品毎のシートのセル（行）の
1番上からチーム毎に順番に貼り付けていくようなマクロは可能でしょうか？ 

 可能、不可能でと答えると、可能でしょうねぇ。
 しかし、お聞きになりたいのは実際のコードなのかな？と思います。


 まずはチームごとに統一してある表のフォーマットはどうなっているか？
 >各チームのブックの各シートにある総数・良品・各不良項目の合計値が 記入されているセル（行）
 　↑↑ここのセルは固定なのか、毎回変わるのか？など
 集計ブックのフォーマットが決まっているかなど（A列は○○で、B列は△△で、）
 掲載されたら分かり易いと思いますが。
 (通行人)
各シートのフォーマットは全て同じで合計値が入る行（セル）は固定です。
具体的には5チーム稼働（変動有り）で1日で4種類の製品検査の場合

ブック：検品A
シート：①

　　　　列C　 列F　　列G　　　　列H　～　　列P　　
行36　　総数　良品　不良合計　○○○　～　×××

ブック：集計
シート：①

　　　　列B　 列C　　列D　　　列E　～　　列L　　
行3　　総数　良品　不良合計　○○○　～　×××
行4　　総数　良品　不良合計　○○○　～　×××
行5　　総数　良品　不良合計　○○○　～　×××
行6　　総数　良品　不良合計　○○○　～　×××
行7　　総数　良品　不良合計　○○○　～　×××

でシートは4種類で④までとなります。
集計シートの行と列は仮です。
あくまで全チームの製品毎の合計を集計したい考えです。

現状どのような様式なのか
集計した様式は
を箇条書きか、現状シートイメージで説明すれば、イン、アウト
が明確となり回答しやすいと思いますよ。

日ごとの検品報告であれば
上記の説明では、日にちの特定はどこで行っているの
検品報告ブック名
検品A.xls
と有りますが、
検品A(06月01日).xls
のようにブック名に月日がある方が検索しやすい
収納フォルダーが日別名であるなら別ですが。
複数ブックから集計ブックにまとめるに当たり
・製品別
・検品チーム別
・１カ月まとめ、チーム別、製品別
・不良率
など現状行っている整理の全てを書かれたほうがよいです
通常最低限の要望を聞いて、ある程度出来上がると、これもついでに
と希望を小出しにする例も有ります。
目で見て、どのような集計結果を希望しているのか、分かりやすく
まとめていただけますか。
現状では、文字から結果を考えあぐねてしまいます。

他サイトですが、最近同様な投稿がありましたから参考まで

http://officetanaka.com/patio/patio.cgi?mode=view&no=3297

（asami）

分かり難い説明で申し訳ありません。

現状は各検品ブックの各製品シート毎の合計の値の行の所を
コピーして集計ブックの各製品のシートに上から1行ずつペーストして
一番下の行で合計が出るようにしてます。
5チームで10製品あるとすれば50回コピー＆ペーストを繰り返してます。
終わった後に集計120605.xlsという名前をつけて1日ごとに保存してます。
各検品ブックは、集計シートにコピーが終われば数値をクリアして
翌日にまたそこに入力シートとして使用してます。

50回コピー＆ペーストしている部分を自動化出来ればと思い投稿いたしました。

（まんぷく）さんの説明で、チームと各行との関連が理解できません、が
毎日コピーペーストを繰り返しているとの事
ならば、シート１の集計だけでよいですから、「マクロの記録」をして、
その内容を張り出してください、そうしますと、操作内容が理解できます。
そのマクロを編集して①～⑩シートまで展開すればよいわけですから。

「マクロの記録」の操作が分からないときは、「EXCEL　マクロの記録」
で検索をかければ解説がたくさん出てきます。

（asami）

マクロ記録してみました。
順番に全検ブックA～Eまで開けてシート１のデータを、集計のシート１に貼付。
製品が複数ある場合はシート２のデータを、集計のシート２に貼付となります。
実際は全検ブックの入力された数値をクリアしてから閉じる。となります。

Sub test()
'
' test Macro
'

' 

    Selection.Copy
    Windows("集計用.xls").Activate
    Range("C1:I2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("全検A.xls").Activate
    ActiveWindow.SmallScroll Down:=25
    Range("C36:P37").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("集計用.xls").Activate
    Range("C5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=28
    Range("C36:P37").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("集計用.xls").Activate
    Range("C7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=28
    Range("C36:P37").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("集計用.xls").Activate
    Range("C9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=26
    Range("C36:P37").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("集計用.xls").Activate
    Range("C11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=24
    Range("C36:P37").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("集計用.xls").Activate
    Range("C13").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("全検A.xls").Activate
    ActiveWindow.Close
    Windows("全検B.xls").Activate
    ActiveWindow.Close
    Windows("全検C.xls").Activate
    ActiveWindow.Close
    Windows("全検D.xls").Activate
    ActiveWindow.Close
    Windows("全検E.xls").Activate
    ActiveWindow.Close
End Sub
確認
最初の説明と２回目の説明とで違いが有ります。
また、説明文とマクロ記録では元データ範囲とコピー先の範囲にも相違があります。
マクロ記録が最終集計と捕らえてよいのですか。

(asami)

２通り試作しました

前提として下記作業をしてください
①Ｄドライブにフォルダー作成
　”検品集計”：ここに”集計用.xls”を収納
　　その下に”検品結果”：ここに”全検A.xls”収納

”集計用.xls”の標準モジュールに下記をコピペしてください
シート1にボタンを１個作り、Com1　を呼び出してください

・”全検＊”Ｂｏｏｋを開いて検査結果データを転記する
　起動しているので、集計後他のフォルダーへ異動可能

・”全検＊”Ｂｏｏｋを開かず検査結果を集計する
　処理速度は速いがデータ読み込みのみ

その応用をお任せします、当方はこれにて

(asami)

例１：検品ブックを開き集計

Sub Com1() 

   Dim md As String


   md = Mid(Date, 6, 5) & "日"
   Ans = MsgBox(md & "集計開始", vbOKCancel, "実行の確認")


   If Ans = vbOK Then
       Application.ScreenUpdating = False     ' 画面更新停止


       Shnam_Get
       検品集計
       Application.ScreenUpdating = True      ' 画面回復


   End If
End Sub


  Sub 検品集計()
 Dim Team() As String
 Dim i As Long, j As Long, k As Long
 Dim Bks
 Dim t As Long, s As Long
 Dim fold As String
 Dim Pat As String
 Dim Buf As String
 Dim md As String


 Bks = ActiveWorkbook.Name       ' 主ファイル名
 Pat = ActiveWorkbook.Path       ' 　　　パス


  t = 5                     ' 検品チーム数
 s = 10                    ' 検品結果シート数
 fold = Pat & "\"          ' フォルダ名


 ReDim Team(t, 2)
 md = Mid(Date, 6, 5) & "日"   ' 月日
 Mid(md, 3, 1) = "月"


 For i = 1 To s
     Worksheets(i).Range("C5:P14").ClearContents
     Worksheets(i).Range("A1").Value = md
 Next


 With Worksheets(1)        ' チーム名、Book名 配列取得
     For i = 1 To t
       Team(i, 1) = .Range("A" & i + 29).Value
       Team(i, 2) = Team(i, 1) & ".xls"
     Next i
 End With


 Windows(Bks).Activate


    Buf = Dir(fold & "検品結果\*.xls")         ' フォルダー内検品結果ファイルを取得


  Do While Buf <> ""
     For k = 1 To t                            ' Book名にチーム名が有るか
       If InStr(Buf, Team(k, 1)) > 0 Then      ' チーム名有り
           Workbooks.Open Filename:=fold & "検品結果\" & Buf
           Windows(Buf).Activate


           For i = 1 To s                      ' Book間シートコピー


               Application.Workbooks(Buf).Worksheets(i).Range("C36:P37").Copy _
                   Application.Workbooks(Bks).Worksheets(i).Range("C" & k * 2 + 3 & ":P" & k * 2 + 4)


           Next
           Windows(Buf).Activate
           ActiveWorkbook.SaveCopyAs fold & "検品結果\" & md & Buf     ' 集計済みフォルダヘ保存


           ActiveWorkbook.Close
           Windows(Bks).Activate
       End If


     Next k


     Buf = Dir()
  Loop
     Windows(Bks).Activate
     For i = 1 To s
         Worksheets(i).Range("A2:P14").Borders.LineStyle = xlContinuous  ' 罫線枠
     Next
         ActiveWorkbook.SaveCopyAs fold & "集計結果\" & md & Bks         ' 集計済みフォルダヘ保存


 End Sub


 Sub Shnam_Get()
 Dim s As Long, i As Long
   s = Worksheets.Count
   For i = 1 To s
       Range("B" & 29 + i) = Worksheets(i).Name
   Next
End Sub

Sub Fold_Up() ' 検品集計処理フォルダー作成 

   Dim d As String
   Dim m As String
   Dim y As String


   m = Mid(Date, 5, 2)     ' 月
   y = Mid(Date, 1, 4)     ' 年


   d = "D:\検品集計 "      ' フォルダ"


   Make_Fold Left(d, 7)            ' 最初に主フォルダー作成
   d = Left(d, 8)                  ' 下位フォルダー
   Make_Fold d & "\検品済み"       '
   Make_Fold d & "\集計結果"       '
   Make_Fold d & "\集計結果\" & m  '

End Sub

'================<< フォルダー作成 >>=======

' 機能説明 :有る：０　　　無い：１

Sub Make_Fold(d As String) 

   Dim er As Long


    On Error GoTo ERTR

ii: MkDir d ' D:

Exit Sub ' 正常作成されれば ER=0

ERTR: '===============<< エラー処理 >>============== 

  If Erl = ii Then     ' エラー起こしたラベルがiiなら
           er = 1      ' フォルダー作成済みフラグ


           Resume Next ' 次の行へ復帰
  End If

End Sub

例２：検品ブックを開かずに集計

Sub Com1() 

   Dim md As String


   md = Mid(Date, 6, 5) & "日"
   Ans = MsgBox(md & "集計開始", vbOKCancel, "実行の確認")


   If Ans = vbOK Then
       Application.ScreenUpdating = False     ' 画面更新停止


       Shnam_Get
       検品集計
       Application.ScreenUpdating = True      ' 画面回復


    End If
End Sub


 Sub 検品集計()
 Dim Team() As String
 Dim i As Long, j As Long
 Dim k As Long, x As Long, y As Long
 Dim Bks
 Dim t As Long, s As Long
 Dim fold As String
 Dim Pat As String
 Dim Buf As String
 Dim md As String
 Dim Sh() As String


 Bks = ActiveWorkbook.Name       ' 主ファイル名
 Pat = ActiveWorkbook.Path       ' 　　　パス


 t = 5                     ' 検品チーム数
 s = 10                    ' 検品結果シート数
 fold = Pat & "\"          ' フォルダ名


 ReDim Team(t, 2)
 ReDim Sh(s)
 md = Mid(Date, 6, 5) & "日"   ' 月日
 Mid(md, 3, 1) = "月"


 For i = 1 To s
     Worksheets(i).Range("C5:P14").ClearContents
     Worksheets(i).Range("A2:P14").Borders.LineStyle = xlContinuous  ' 罫線枠
     Worksheets(i).Range("A1").Value = md
     Sh(i) = Worksheets(1).Range("B" & i + 29).Value
 Next


 With Worksheets(1)        ' チーム名、Book名 配列取得
     For i = 1 To t
       Team(i, 1) = .Range("A" & i + 29).Value
       Team(i, 2) = Team(i, 1) & ".xls"
     Next i
 End With


 Windows(Bks).Activate


    Buf = Dir(fold & "検品結果\*.xls")      ' フォルダー内検品結果ファイルを取得


 Do While Buf <> ""
     For k = 1 To t                           ' Book名にチーム名が有るか
       If InStr(Buf, Team(k, 1)) > 0 Then     ' チーム名有り
           For i = 1 To s


             With Worksheets(i)


               For y = 0 To 1      ' 売上データコピー
                 For x = 3 To 16
                   .Cells(k * 2 + y + 3, x).Value = ExecuteExcel4Macro("'" & fold & "検品結果\" & "[" & Buf & "]" & Sh(i) & "'!R" & 36 + y & "C" & x)
                 Next
               Next


             End With
          Next


       End If


     Next k


     Buf = Dir()
  Loop


     Windows(Bks).Activate
     For i = 1 To t        ' 検品チームBook　起動
'        Workbook.Close Filename:=Team(i, 2)
     Next i


 End Sub


 Sub Shnam_Get()
 Dim s As Long, i As Long
   s = Worksheets.Count
   For i = 1 To s
       Range("B" & 29 + i) = Worksheets(i).Name
   Next
End Sub
Sub Fold_Up() ' 検品集計処理フォルダー作成 


   Dim d As String
   Dim m As String
   Dim y As String


   m = Mid(Date, 5, 2)     ' 月
   y = Mid(Date, 1, 4)     ' 年


   d = "D:\検品集計 "      ' フォルダ"


   Make_Fold Left(d, 7)            ' 最初に主フォルダー作成
   d = Left(d, 8)                  ' 下位フォルダー
   Make_Fold d & "\検品済み"       '
   Make_Fold d & "\集計結果"       '
   Make_Fold d & "\集計結果\" & m  '
End Sub

'================<< フォルダー作成 >>=======

' 機能説明 :有る：０　　　無い：１

Sub Make_Fold(d As String) 

   Dim er As Long


    On Error GoTo ERTR
ii: MkDir d ' D:

Exit Sub ' 正常作成されれば ER=0

ERTR: '===============<< エラー処理 >>============== 

  If Erl = ii Then     ' エラー起こしたラベルがiiなら
           er = 1      ' フォルダー作成済みフラグ


           Resume Next ' 次の行へ復帰
  End If
End Sub

(asami)

コメント返信：

[ 一覧(最新更新順) ]

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.