エクセルのマクロであるフォルダ内にある全エクセルファイルのシート1！（

質問

エクセルのマクロであるフォルダ内にある全エクセルファイルのシート1！（A1：X365）の値を取得し、コピー元のエクセルファイル名のシートに貼付ける方法を教えて頂けないでしょうか？できればコピー元のエクセルファイルは開かずに実行させたいです。エクセルは2003を使っています。

回答No.5

DOUGLAS_ · ベストアンサー

おはようございます。DOUGLAS_ です。

＞「A1：X365」という読み込み範囲を指定する
＞SQL文 の書き方が分かりませんでしたので、・・・
　前回答の 参照URL に書いてありました。　　(;^_^A

　前回答の下記２点を訂正していただければ結構です。

１）
myRS.Open "select * from [Sheet1$]", myCon
を
myRS.Open "select * from [Sheet1$A1:X356]", myCon
に差し替え。

２）
Range(Range("Y1"), Cells(1, Columns.Count)).EntireColumn.ClearContents
Range(Range("A366"), Cells(Rows.Count, 1)).EntireRow.ClearContents
の２行を削除。

　なお、ご存じかとは存じますが、「参照設定」というのは、Visual Basic Editor（VBE）で
１）[ツール(T)] - [参照設定(R)...] で、[参照設定 - VBProject] ダイアログ を開きます。
２）[参照可能なライブラリ ファイル(A):] の下の一覧の中から「Microsoft ActiveX Data Objects 2.x Library」というような文字列の書かれた項目の前の チェックボックス を オン にします。
　私の環境では「2.x」の部分が「2.0」・「2.1」・「2.5」・「2.6」・「2.7」・「2.8」と ６通り ありましたので、番号の一番大きな「2.8」に参照設定しました。
３）最後に [OK] を クリック して、[参照設定 - VBProject] ダイアログ を閉じます。

　なお、私の書いた マクロ は、マクロ が書かれた ブック には、何も変化はありません。
　新規ブック を開いて、そこに データ を読み込み、別名で保存するようにしてあります。

＞最終的に私がやりたいことは60ある同一フォームのエクセルファイルの、
＞A1からX365に入力された数値を
＞それぞれのセル位置ごとにマスターのファイルで合計を出したい
とのことですが、「60ある同一フォームのエクセルファイル」は、同じ フォルダ に入っていることが要件です。

　VBA の知識がおありでしたら、私の書いた マクロ を適当に手直ししてくだされば、複数の フォルダ からの読み込みもできるようになります。
　では、ご健闘をお祈りします。　　<(_ _)>

お礼

おはようございます。
私の言葉足らずの質問、要望に熱心に回答頂き本当にありがとうございました。おかげさまでやりたかったことは完全に出来るようになりました。
また、いろいろと勉強にもなりました。
大変感謝しております。
本当にありがとうございました。

回答No.4

DOUGLAS_

毎度お騒がせいたします。DOUGLAS_ です。
　ADO を使って データ接続 ということで、
http://antonsan.net/study/excel/excel021.php#9
を参考に書いてみました。

　「Microsoft ActiveX Data Object 2.x Library」に参照設定なさってください。「2.x」の「x」は数字の大きなものを選べばよかったと存じます。

　ただし、「A1：X365」という読み込み範囲を指定する SQL文 の書き方が分かりませんでしたので、読み込んだ後に、範囲外を削除する、というような ダサイ ヤリカタ になってます。

' 参照設定「Microsoft ActiveX Data Object 2.x Library」
Sub test()
　Application.ScreenUpdating = False

'「あるフォルダ」の指定
　Dim MyPath As String
　With Application.FileDialog(msoFileDialogFolderPicker)
　　.Title = "フォルダを選択してください"
　　.InitialFileName = "D:\"
　　.Show
　　MyPath = .SelectedItems(1)
　End With

'Ｄドライブ 直下に「あるフォルダ」名で、ブック を保存
　Workbooks.Add Template:="ブック"
　ActiveWorkbook.SaveAs Filename:= _
　　　　"D:\" & Replace(Replace(MyPath, ":", "："), "\", "￥") & ".xls"

'「あるフォルダ」内の、ブック を検索
　Dim MyName 'As String
　Dim myCon As New ADODB.Connection
　Dim myRS As New ADODB.Recordset
　MyName = Dir(MyPath & "\*.xls")
　Do

'アクティブシート を「コピー元のエクセルファイル名」に変える
　　ActiveSheet.Name = Replace(MyName, ".xls", "")

'「シート1！（A1：X365）の値を取得し、」・「シートに貼付ける」
　　With myCon
　　　.Provider = "Microsoft.Jet.OLEDB.4.0;"
　　　.Properties("Extended Properties") = "Excel 8.0;HDR=NO"
　　　.Open MyName
　　End With
　　myRS.Open "select * from [Sheet1$]", myCon
　　Range("A1").CopyFromRecordset myRS
　　Range(Range("Y1"), Cells(1, Columns.Count)).EntireColumn.ClearContents
　　Range(Range("A366"), Cells(Rows.Count, 1)).EntireRow.ClearContents
　　myRS.Close
　　myCon.Close

'「あるフォルダ」内の、ブック がなくなるまで、繰り返す。
　　MyName = Dir
　　If MyName <> "" Then
　　　Sheets.Add after:=ActiveSheet, Type:="ワークシート"
　　Else
　　　Exit Do
　　End If
　Loop

'再保存
　Set myRS = Nothing
　Set myCon = Nothing
　ActiveWorkbook.Sheets(1).Activate
　ActiveWorkbook.Save
　Application.ScreenUpdating = True
End Sub

回答No.3

DOUGLAS_

#2 DOUGLAS_ です。

　美味しそうな エサ に食らい付いて、とても初歩的な ミス をしてしまいました。
　下記２点を訂正します（なお、変数は、都度、宣言しています）。

１）
MyName = Dir(MyPath & "\*.xls")
の前に
　Dim i As Integer
　Dim j As Integer
　Dim myArr(364, 23) As Variant
を追加します。

２）
Range("A1：X365") = ExecuteExcel4Macro("'" & MyPath & "\[" & MyName & "]Sheet1'!R1C1:R365C24")
を
　　For i = 1 To 24
　　　For j = 1 To 365
　　　　myArr(j - 1, i - 1) = ExecuteExcel4Macro("'" & MyPath & "\[" & MyName & "]Sheet1'!R" & j & "C" & i)
　　　Next
　　Next
　　Range("A1：X365") = myArr
に差し替えます。

　ただし、この方法では、とても時間がかかり、パソコン にも、かなり負荷が掛かってそうですので、別の方法を考えてみます。
　大変お騒がせいたしました。　　　<(_ _)>

補足

DOUGLASさん回答ありがとうございます。やはりコピーしてシートを作っての繰り返しはパソコンへの負荷が大きいのですね。
最終的に私がやりたいことは60ある同一フォームのエクセルファイルの、A1からX365に入力された数値をそれぞれのセル位置ごとにマスターのファイルで合計を出したいと思っています。シートをファイル数分コピーして増やそうと思ったのは一つのファイルにまとめれば後は私のエクセル関数の知識でもやりたいことは達成できると思ったからです。
他にいい方法があれば教えて下さい。お願いします。

回答No.2

DOUGLAS_

面白そうなお題でしたので、乗ってみました。

Sub test()
　Application.ScreenUpdating = False

'「あるフォルダ」の指定
　Dim MyPath As String
　With Application.FileDialog(msoFileDialogFolderPicker)
　　.Title = "フォルダを選択してください"
　　.InitialFileName = "D:\"
　　.Show
　　MyPath = .SelectedItems(1)
　End With

'Ｄドライブ 直下に「あるフォルダ」名で、ブック を保存
　Workbooks.Add Template:="ブック"
　ActiveWorkbook.SaveAs Filename:= _
　　　　"D:\" & Replace(Replace(MyPath, ":", "："), "\", "￥") & ".xls"

'「あるフォルダ」内の、ブック を検索
　Dim MyName 'As String
　MyName = Dir(MyPath & "\*.xls")
　Do

'アクティブシート を「コピー元のエクセルファイル名」に変える
　　ActiveSheet.Name = Replace(MyName, ".xls", "")

'「シート1！（A1：X365）の値を取得し、」・「シートに貼付ける」
　　Range("A1：X365") = ExecuteExcel4Macro("'" & MyPath & "\[" & MyName & "]Sheet1'!R1C1:R365C24")

'「あるフォルダ」内の、ブック がなくなるまで、繰り返す。
　　MyName = Dir
　　If MyName <> "" Then
　　　Sheets.Add after:=ActiveSheet, Type:="ワークシート"
　　Else
　　　Exit Do
　　End If
　Loop

'再保存
　ActiveWorkbook.Sheets(1).Activate
　ActiveWorkbook.Save
　Application.ScreenUpdating = True
End Sub

回答No.1

n-jun

ブックを開かないで読む
http://www.officetanaka.net/excel/vba/tips/tips28.htm

とか、あとは外部接続などになるのかな。
開かないでやると、結構面倒な感じがします。

お礼

ありがとうございました。勉強になりました。