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

解決済みの質問

エクセル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しかない場合、
アルファベットではなく、1~3といった場合、
5枚だけではなく、10枚など増えた場合。

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

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

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

投稿日時 - 2008-02-20 13:52:54

QNo.3793100

困ってます

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

こんばんは。

>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

投稿日時 - 2008-02-20 18:25:31

お礼

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

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

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

投稿日時 - 2008-02-22 09:43:54

ANo.4

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

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

回答(5)

ANo.5

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

投稿日時 - 2008-02-21 09:06:45

お礼

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

投稿日時 - 2008-02-22 09:41:33

ANo.3

「まとめ.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

こんなんですか。

投稿日時 - 2008-02-20 17:22:33

ANo.2

逆にフォルダの中にエクセルファイルがあって、そのファイル名からシート名を持ってくる方がいいと思います。
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

投稿日時 - 2008-02-20 14:41:12

補足

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

投稿日時 - 2008-02-20 15:14:21

お礼

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

投稿日時 - 2008-02-22 11:51:33

ANo.1

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

投稿日時 - 2008-02-20 14:28:50

補足

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

投稿日時 - 2008-02-20 15:12:32

あなたにオススメの質問