エクセルVBAでの質問です。

質問

まとめ.xlsに、「まとめ」「グラフ」「A」「B」「C」「D」「E」というシートがあって、それと一緒に、A.xls、B.xls、C.xls、D.xls、E.xlsというファイルを開いた際に、A.xlsの、G2:I54をまとめ.xlsのAのシートのA1に、B.xlsの、G2:I54をまとめ.xlsのBのシートのA1に・・・といった感じでコピーを行いたいと思い、以下のようにマクロを組みました。

Dim I(4) As String

I(0) = "A"
I(1) = "B"
I(2) = "C"
I(3) = "D"
I(4) = "E"

Sheets("まとめ").Select

For J = 0 To 4 Step 1

Sheets("" + I(J) + "").Select
Windows("" + I(J) + ".xls").Activate
Range("G2:I54").Select
Selection.Copy

ThisWorkbook.Activate
Range("A1").Select
ActiveSheet.Paste

Application.CutCopyMode = False
Workbooks("" + I(J) + ".xls").Close SaveChanges:=False

Next J

ThisWorkbook.Activate
Sheets("まとめ").Select
Range("A1").Select

この状態では、必ずA～Eのシートと、A～E.xlsが存在しないと処理できないのですが、情報量が変わった場合でも同じような処理を行いたいのです。
たとえば、A～CのシートとA～C.xlsしかない場合、
アルファベットではなく、１～３といった場合、
５枚だけではなく、１０枚など増えた場合。

まとめ.xlsの「まとめ」と、「グラフ」のシートには、それぞれA～Eに貼られたデータから引用したり、グラフ化したりしているため、シートの入れ替えは行うことができず、純粋に、「値のコピー」としてもってきたいと思っています。

原則として、A～Eのシートに貼り付けるA～E.xlsに存在するシート名は、A.xlsはA、B.xlsはB・・・といった感じになっています。
それが数字になっても、文字になってもその規則に変更はありません。

分かりにくい説明ですみません。
分かる方、よろしくお願いします。

回答No.4

Wendy02 · ベストアンサー

こんばんは。

>A.xls、B.xls、C.xls、D.xls、E.xlsというファイルを開いた際
と#2さんの補足の意味を考えると、そういう感じでファイルを開いた状態にしてマクロを実行するというところに、危うさがあります。「フォルダも多岐に渡るため」なら、通常は、シートに、フルアドレスのファイル名等を書き込んでおいて、それを、一つずつ呼び出すようにするのが普通です。

以下の場合は、必ず、シート名が優先します。シート名のあるファイル名で、なおかつ、ワークブックが開いているものに限り、値コピーされるという仕組みになっています。ブックでオープンされていないものに対しては、コピーはパスされます。

なお、現行では、
Workbooks(shts(j) & ".xls").ActiveSheet.Range("G2:I52").Copy
コピーされる側のブックのシートは、ActiveSheet になっています。

Sub TestMarco()
　　Dim i As Integer
　　Dim j As Integer
　　Dim shts() As Variant
　　Dim buf As Variant
　　With ThisWorkbook
　　　　'シート名格納
　　　　For i = 1 To .Worksheets.Count
　　　　　　'グラフは、ワークシートではないので、本来チェックは要りません。
　　　　　　　If Not .Worksheets(i).Name Like "まとめ*" And _
　　　　　　　　Not .Worksheets(i).Name Like "グラフ*" Then
　　　　　　　　ReDim Preserve shts(j)
　　　　　　　　shts(j) = .Worksheets(i).Name
　　　　　　　　j = j + 1
　　　　　　End If
　　　　Next i
　　　　'ブック名チェック
　　　　On Error Resume Next
　　　　For j = LBound(shts()) To UBound(shts())
　　　　　　buf = Workbooks(shts(j) & ".xls").Name
　　　　　　If buf = "" Then
　　　　　　　　shts(j) = Empty
　　　　　　　　Err.Clear
　　　　　　Else
　　　　　　　　buf = ""
　　　　　　End If
　　　　Next j
　　　　On Error GoTo 0

　　　　For j = LBound(shts()) To UBound(shts())
　　　　　　'ブック名がオープンしていないものはパス
　　　　　　If Not IsEmpty(shts(j)) Then
　　　　　　　　Workbooks(shts(j) & ".xls").ActiveSheet.Range("G2:I52").Copy
　　　　　　　　.Worksheets(shts(j)).Range("A1").PasteSpecial (xlPasteValues)
　　　　　　　　Application.CutCopyMode = False
　　　　　　　　Workbooks(shts(j) & ".xls").Close False
　　　　　　End If
　　　　Next j
　　　　Application.Goto .Worksheets("まとめ").Range("A1")
　　End With

End Sub

お礼

＞ファイルを開いた状態にしてマクロを実行するというところに、危うさが

そうなんですね・・・。
ご忠告ありがとうございます。

今回、こちらのVBAで理想どおりの結果を得ることができました。
ありがとうございます。
大変勉強になりました。

回答No.5

okormazd

ANo.3です。

補足

使用するbookにいちいち貼り付けるのは面倒だが、一度作ってしまえば複雑なフォルダもファイル名も枚数も関係ありません。

余計なところがありました。

i = 1
sname = .Sheets(i).Name
While sname <> fname
i = i + 1
'sname = .Sheets(i).Name　　　　　　'これ余計
If i > sn Then
MsgBox "シートがありません。"
Exit Sub
End If
sname = .Sheets(i).Name
Wend

お礼

ありがとうございます。
コピー元ファイルは結構な数になったりするので、
あまり触りたくないのですが、大変参考になりました。
今後、何かの折に活用させていただきたいと思います。

回答No.3

okormazd

「まとめ.xls」は、すでに開いてあるとする。

>ファイルを開いた際に、A.xlsの・・・コピー

次のコードを、
A.xls,B.xls,C.xls・・・・
のThisWorkBookに貼り付ける。

Private Sub Workbook_Open()

Application.Run "まとめ.xls!datacopy"

End Sub

A.xls,B.xls,C.xls・・・・などのデータを変更したときに反映されるように、
次のコードを各ブックのSheet1にはりつける。(これらのブックのデータがSheet1にあるとしている。)

Private Sub Worksheet_Change(ByVal Target As Range)

r = Target.Row
c = Target.Column

If r >= 2 And r <= 54 And c >= 7 And c <= 9 Then

Application.Run "まとめ.xls!datacopy"

End If

End Sub

次のコードを「まとめ.xls」の標準モジュールに貼り付ける。

Sub datacopy()

r1 = 2
c1 = 7
r2 = 54
c2 = 9

fname0 = ActiveWorkbook.Name
fnl = Len(fname0)
fname = Left(fname0, fnl - 4)

With Workbooks("まとめ.xls")
sn = .Sheets.Count
i = 1
sname = .Sheets(i).Name
While sname <> fname
sname = .Sheets(i).Name
i = i + 1
If i > sn Then
MsgBox "シートがありません。"
Exit Sub
End If
sname = .Sheets(i).Name
Wend

With Workbooks(fname0).Sheets(1)

.Range(.Cells(r1, c1), .Cells(r2, c2)).Copy

End With

.Sheets(i).Cells(r1, c1).PasteSpecial

Application.CutCopyMode = False

End With

End Sub

こんなんですか。

回答No.2

suz83238

逆にフォルダの中にエクセルファイルがあって、そのファイル名からシート名を持ってくる方がいいと思います。
Sub xxx()
fol = "C:\Documents and Settings\～\123\"　'エクセルファイルのあるフォルダ名
fname = Dir(fol & "*.xls", vbNormal)
Do While fname <> ""
Workbooks.Open fol & fname
Range("G2:I5").Copy
ThisWorkbook.Activate
Sheets(Left(fname, Len(fname) - 4)).Range("A1").PasteSpecial
Workbooks(fname).Close
fname = Dir()
Loop
End Sub

お礼

ありがとうございます。
無事、解決しました。
この方法も、大変勉強になりましたので、
いつかの折に活用させていただきたいと思います。

補足

フォルダも多岐に渡るため、できれば細かい指定は
したくないのですが・・・（すみません。）

回答No.1

okormazd

やりたいことは大体わかりますが、質問のコードでは、無理でしょう。
ちょっとちぐはぐな感じです。
このコードに沿わなくてもいいのですか。

補足

このコードに沿わなくてもかまいません。
こんな風にやっていて、こんな風にやりたいのですが・・・
という意図でもあり、貼り付けております。