ExcelVBA別フォルダにあるブックのコピー方法

質問

ExcelVBAでデータを条件に応じてコピーしたいと思っています。

同一階層に「VBAファイル.xls」「1_フォルダA」「2_フォルダB」「3_フォルダC」があります。
「1_フォルダA」と「2_フォルダB」には年代別に分かれたファイルがあります。
ファイルとフォルダの構造は以下の通りです。

VBAファイル.xls
1_フォルダA
　∟1999_ファイルA.xls
　∟2000_ファイルA.xls
　∟2001_ファイルA.xls
　∟2002_ファイルA.xls
　∟2003_ファイルA.xls
　∟2004_ファイルA.xls
　∟2005_ファイルA.xls
　∟2006_ファイルA.xls
　∟2007_ファイルA.xls
　∟2008_ファイルA.xls
　∟2009_ファイルA.xls
　∟2010_ファイルA.xls
　∟2011_ファイルA.xls
　∟2012_ファイルA.xls
2_フォルダB
　∟1999_ファイルB.xls
　∟2000_ファイルB.xls
　∟2001_ファイルB.xls
　∟2002_ファイルB.xls
　∟2003_ファイルB.xls
　∟2004_ファイルB.xls
　∟2005_ファイルB.xls
　∟2006_ファイルB.xls
　∟2007_ファイルB.xls
　∟2008_ファイルB.xls
　∟2009_ファイルB.xls
　∟2010_ファイルB.xls
　∟2011_ファイルB.xls
　∟2012_ファイルB.xls
3_フォルダC
　∟ファイルC_結果.xls

「VBAファイル.xls」では添付の画像のような「ActiveXコントロール」を設定しました。
コンボボックスで西暦を選択すると、選択した年を中心年として、
前後1年を合わせて合計３年がラベルに表示されます。
その年のファイルのデータが「ファイルC_結果.xls」にコピーされるようにしたいです。

例えば画像のように「2007」を選択した場合、
・「2006_ファイルA.xls」のC7～C25を「ファイルC_結果.xls」のD7～D25にコピー
・「2007_ファイルA.xls」のC7～C25を「ファイルC_結果.xls」のE7～E25にコピー
・「2008_ファイルA.xls」のC7～C25を「ファイルC_結果.xls」のF7～F25にコピー
・「2006_ファイルB.xls」のC6～C24を「ファイルC_結果.xls」のH7～H25にコピー
・「2007_ファイルB.xls」のC6～C24を「ファイルC_結果.xls」のI7～I25にコピー
・「2008_ファイルB.xls」のC6～C24を「ファイルC_結果.xls」のJ7～J25にコピー
というようにしたいです。

「ファイルC_結果.xls」のD/E/F列はファイルAのデータで、
D列は前年、E列は当年、F列は翌年
H/I/J列はファイルBのデータで、
H列は前年、I列は当年、J列は翌年の値をコピーして貼り付けたいです。

また、可能であれば「ファイルC_結果.xls」は原本なので、
値をコピーする際にファイル名が変更できればよりよいです。

いろいろ書いてしまい、うまく伝わっているか不安なのですが
処理するデータが多くとても困っています。
お知恵のある方、どなたか助けていただけますと幸いです。
よろしくお願いいたします。

回答No.2

cj_mover · ベストアンサー

＃１、ｃｊです。
補足欄への返答です。

> 最後にファイル名を付けるときに、コンボボックスで選択した年を先頭として(この場合では)【2007_ファイルC.xls】としたい........

　　' ' "ファイルC_2006～2008年結果.xls"形式の名前を付け保存して閉じる
　　sht結果.Parent.Close SaveChanges:=True, Filename:=sMyDir & "3_フォルダC\ファイルC_" & Label1.Caption & "結果.xls"　　'　　●

の部分を以下のように差し替えてみてください。

　　' ' "ファイルC_2006～2008年結果.xls"形式の名前を付け保存して閉じる
　　sht結果.Parent.Close SaveChanges:=True, Filename:=sMyDir & ComboBox1.Value & "_ファイルC.xls"　　'　　●

返答、以上です。

お礼

ありがとうございました！できました！本当にありがとうございます！

回答No.3

cj_mover

＃１、２、ｃｊです。
＃２に追記です。

設問が詳しくないので迷いますが、
やはり、「3_フォルダC」に保存する、ということでしたら、

　　' ' "ファイルC_2006～2008年結果.xls"形式の名前を付け保存して閉じる
　　sht結果.Parent.Close SaveChanges:=True, Filename:=sMyDir & "3_フォルダC\" & ComboBox1.Value & "_ファイルC.xls" '　　●

という風になります。

追記、以上です。

お礼

丁寧に回答下さいましてありがとうございました。本当に助かりました。

回答No.1

cj_mover

' ' ●サブフォルダ名
' ' ●ブック名
' ' ●シート名
' ' ●セル番地
' ' ●ActiveXコントロールのオブジェクト名
' ' ●ファイルが存在する年次期間
' ' ●作成したブックの新しい名前
' ' 相違無いか要確認、適宜修正。
Private Sub CommandButton1_Click()　　'　　●

　　Dim vTgYear As Variant
　　Dim sht結果 As Worksheet
　　Dim sht元データ As Worksheet
　　Dim sMyDir As String
　　Dim sWbkFullName As String
　　Dim sShtName As String
　　Dim sMsg As String
　　Dim i As Long

　　vTgYear = ComboBox1.Value　　'　　●
　　If Not vTgYear Like "####" Then
　　　　MsgBox "年次を指定してからやり直し", vbExclamation
　　　　Exit Sub
　　End If

　　Select Case vTgYear
　　Case 1999 To 2012　　'　　●
　　Case Else
　　　　MsgBox "1999～2012の間で年次を指定してからやり直し", vbExclamation　　'　　●
　　　　Exit Sub
　　End Select

　　sMyDir = ThisWorkbook.Path & "\"

　　With Application
　　　　.ScreenUpdating = False
'　　　　.DisplayAlerts = False
　　　　.Calculation = xlCalculationManual
　　End With

　　' ' ファイルC_結果.xls を開く
　　sWbkFullName = sMyDir & "3_フォルダC\ファイルC_結果.xls"　　'　　●
　　sShtName = "Sheet1"　　'　　●
　　On Error Resume Next
　　Set sht結果 = Workbooks.Open(sWbkFullName).Sheets(sShtName)
　　On Error GoTo 0
　　If sht結果 Is Nothing Then
　　　　MsgBox sWbkFullName & vbLf & sShtName & vbLf & "開くことが出来ませんでした", vbExclamation
　　　　Exit Sub
　　End If
　　' ' 出力先のセル範囲を値消去
　　sht結果.Range("D7:F25,H7:J25").ClearContents　　'　　●

　　' ' 前年～翌年、ループ
　　For i = -1 To 1
　　　　' ' 1_フォルダA
　　　　sWbkFullName = sMyDir & "1_フォルダA\" & vTgYear + i & "_ファイルA.xls"　　'　　●
　　　　sShtName = "Sheet1"　　'　　●
　　　　On Error Resume Next
　　　　Set sht元データ = Workbooks.Open(sWbkFullName).Sheets(sShtName)
　　　　On Error GoTo 0
　　　　If sht元データ Is Nothing Then
　　　　　　sMsg = sMsg & vbLf & "●" & sWbkFullName & vbLf & sShtName
　　　　Else
　　　　　　sht結果.Range("E7:E25").Offset(, i).Value = sht元データ.Range("C7:C25").Value　　'　　●
　　　　　　sht元データ.Parent.Close SaveChanges:=False
　　　　　　Set sht元データ = Nothing
　　　　End If

　　　　' ' 2_フォルダB
　　　　sWbkFullName = sMyDir & "2_フォルダB\" & vTgYear + i & "_ファイルB.xls"　　'　　●
　　　　sShtName = "Sheet1"　　'　　●
　　　　On Error Resume Next
　　　　Set sht元データ = Workbooks.Open(sWbkFullName).Sheets(sShtName)
　　　　On Error GoTo 0
　　　　If sht元データ Is Nothing Then
　　　　　　sMsg = sMsg & vbLf & "●" & sWbkFullName & vbLf & sShtName
　　　　Else
　　　　　　sht結果.Range("I7:I25").Offset(, i).Value = sht元データ.Range("C6:C24").Value　　'　　●
　　　　　　sht元データ.Parent.Close SaveChanges:=False
　　　　　　Set sht元データ = Nothing
　　　　End If
　　Next i

　　' ' "ファイルC_2006～2008年結果.xls"形式の名前を付け保存して閉じる
　　sht結果.Parent.Close SaveChanges:=True, Filename:=sMyDir & "3_フォルダC\ファイルC_" & Label1.Caption & "結果.xls"　　'　　●

　　With Application
　　　　.ScreenUpdating = True
'　　　　.DisplayAlerts = True
　　　　.Calculation = xlCalculationAutomatic
　　End With
　　Set sht結果 = Nothing

　　If sMsg = "" Then
　　　　MsgBox Label1.Caption & vbLf & "処理完了", vbInformation
　　Else
　　　　MsgBox sMsg & vbLf & "開くことが出来ませんでした", vbExclamation
　　End If
End Sub

補足

遅くなりまして申し訳ありません。いろいろ試していたらお礼が遅くなってしまいました。カテゴリー別にデータが複数行にわたっているのでいろいろやっているのですが、一つだけ解決できないことができないのでよろしければ教えてください。最後にファイル名を付けるときに、コンボボックスで選択した年を先頭として(この場合では)【2007_ファイルC.xls】としたいのですがどうしてもうまくできません。どうしたら解決するかご教授いただけますと幸いです。よろしくお願い致します。