こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

VBAでご相談です!

Excel2010使用。
VBA初心者です。
VBAでご相談させて下さい。
複数のファイルを1つにまとめる
作業をしたいと思い、ググったところ
あるサイトで下記のコードを見つけました。
ただ、このコードでは、ファイルをダイアログから
選択する形になります。
これを、ファイルを指定した状態で実行させたいと思い、
自分で試してみたのですが、上手くいきませんでした。
同一フォルダ内には4つのファイルがあり、全て同じ様式の
シートが複数あります。ただ、フォルダ名が毎月変更になります。
この同一フォルダ内のデータの中の特定のシートを一つのシートに
まとめたいと考えているのですが、可能でしょうか?
可能であれば、アドバイスいただけるとありがたいです。

Sub sample()
Dim myPath As String
Dim wb_A As Workbook, wb_B As Workbook
Dim i As Long, s As Long
myPath = Application.GetOpenFilename(("Excel ファイル (*.xls), *.xls"), , "データを蓄積するブックを選択して下さい。")
If myPath = "False" Then Exit Sub
Set wb_A = Workbooks.Open(myPath)
myPath = Application.GetOpenFilename(("Excel ファイル (*.xls), *.xls"), , "データを取得するブックを選択して下さい。")
If myPath = "False" Then Exit Sub
Set wb_B = Workbooks.Open(myPath)
With wb_B
For i = 1 To .Worksheets.Count 'wb_Bループ
For s = 1 To wb_A.Worksheets.Count 'wb_Aループ
'同じ名前のシートがあるとき データコピー
If .Worksheets(i).Name = wb_A.Worksheets(s).Name Then
.Worksheets(i).Range("A1").CurrentRegion.Copy _
wb_A.Worksheets(i).Range("A65536").End(xlUp).Offset(1)
Exit For
End If
'同じ名前のシートが無いとき シートコピー
If s = wb_A.Worksheets.Count Then
.Worksheets(i).Copy Before:=wb_A.Sheets(1)
End If
Next s
Next i
wb_B.Close False
MsgBox "完了"
End With
End Sub

※長文、説明下手で申し訳ありませんが
よろしくお願いします。

<参考URL>
  http://www.excel.studio-kazu.jp/kw/20040709212700.html

投稿日時 - 2012-09-04 21:15:14

QNo.7680773

すぐに回答ほしいです

質問者が選んだベストアンサー

>これを、ファイルを指定した状態で実行させたいと思い、
『指定した状態』とは?
たとえば下記のマクロを書いてあるBook、
つまりThisWorkbookを開いた状態でマクロを実行する、という解釈で良いでしょうか?



以下、サンプルです。
※集約したい特定のシートのシート名は共通だと解釈してConst sName = "DATA"の箇所で指定するようにしています。
マクロ内容としては
1)GetOpenFilenameダイアログで複数Bookをまとめて選択します。
2)選択したファイルを順次開いて処理後閉じます。
3)ThisWorkbookにシートを追加してそこに集約します。

Sub try()
  Const sName = "DATA" '特定のシートのシート名に変更必要。
  Dim dest As Range
  Dim r  As Range
  Dim x, ary, ar

  On Error GoTo errout
  '取得するBookをCtrl+クリックでまとめて選択。
  x = Application.GetOpenFilename("XLfiles,*.xl*", MultiSelect:=True)
  If VarType(x) = vbBoolean Then MsgBox "cancel": Exit Sub

  Application.ScreenUpdating = False
  If IsArray(x) Then
    ary = x
  Else
    ReDim ary(0)
    ary(0) = x
  End If
  
  'このマクロが書いてあるBookにSheetを追加して集約。 _
   あるSheetに変更するなら差替え必要。
  Set dest = ThisWorkbook.Worksheets.Add.Range("A1")
  'Set dest = ThisWorkbook.Worksheets("集約").Range("A1")
  'dest.Worksheet.UsedRange.Clear '"集約"シートの既存クリアが必要な場合。
  
  For Each ar In ary
    With Workbooks.Open(ar, ReadOnly:=True)
      On Error Resume Next
      Set r = .Sheets(sName).UsedRange
      On Error GoTo errout
      If Not r Is Nothing Then
        dest.Value = ar
        Set r = Excel.Range(r.Worksheet.Range("A1"), r.Item(r.Count))
        r.Copy dest.Offset(, 1)
        Set dest = dest.Offset(r.Rows.Count)
        Set r = Nothing
      End If
      .Close False
    End With
  Next

errout:
  Application.ScreenUpdating = True
  With Err
    If .Number <> 0 Then
      MsgBox .Number & "::" & .Description
    End If
  End With
End Sub

dataシートを列いっぱい使っていたらエラーになります。
その他、同名Bookを既に開いていてOpenをキャンセルするとエラーになります。
そういったエラー対策は無しで、メッセージもExcelに任せてます。
必要であれば工夫してみてください。

投稿日時 - 2012-09-04 23:11:37

お礼

end-u様、ありがとうございます。
教えていただいたコード、早速試して見ました。
説明が下手であった為、残念ながら私の意図する
動作ではありませんでした。ただ、内容を1つずつ
紐解いていくと、すごく勉強になる内容でした。
今回、私がしようとしていることは少し複雑というか
説明が難しくてなかなか伝えきれないもどかしさが
あります。なので、end-u様から教えて頂いた内容を
利用させていただきながら、なんとか自分で解決して
いきたいと思います。ありがとうございました!

投稿日時 - 2012-09-05 20:21:46

ANo.1

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問