VBAでおしえてください

質問

お世話になっております。
今、５個のエクセルファイルがあり、それぞれ複数のシートで構成されていますが、シート名、並び順は、５個のファイルとも共通です。
シート名は、sheet1から、A,B,C,D,・・・・と割り振っております。
ここで、同じシート名のdataを同じシート内に集めたいです。。
(元DATAの形式）
ファイル１
SheetA SheetB
セル DATA セル DATA
B2 2 B2 8
B3 3 B3 5
B4 4 B4 6
ファイル2
SheetA SheetB
セル DATA セル DATA
B2 6 B2 2
B3 5 B3 3
B4 1 B4 4

VBA変換後
ファイル1
SheetA
セル DATA セル DATA
B2 2 C2 6
B3 3 C3 5
B4 4 C4 1

よろしくお願いいたします

回答No.10

papayuka · ベストアンサー

前質問からの乗りかかった船ですので、横からで失礼します。
こちらの認識にあやまりがあるかも知れませんが、こんな処理だと判断しました。

処理対象となる5個のブックと「同じシート数がある」新規ブックを作り、サンプルマクロ（Test3）を標準モジュールにコピペします。
マクロを実行すると、一緒に開いていて非表示になっていない全てのブックに対して、マクロのあるブックの各シートに各ブックのB列を転記して行きます。

Sub Test3()
Dim wb As Workbook, i As Integer
For Each wb In Workbooks
　If Not wb Is ThisWorkbook And Windows(wb.Name).Visible Then
　　 For i = 1 To wb.Worksheets.Count
　　　　 wb.Worksheets(i).Columns(2).Copy _
　　　　　 ThisWorkbook.Worksheets(i).Range("IV2"). _
　　　　　　　End(xlToLeft).Offset(0, 1).EntireColumn
　　 Next i
　End If
Next wb
End Sub

変数の使い方とループ処理と条件分岐、この３つを覚える事で応用の幅が広がります。
前質問の回答を読んで急いでいるのは解りましたが、丸投げばかりではいつまでも身につきませんよ。

お礼

できました＾＾
＞前質問の回答を読んで急いでいるのは解りましたが、丸投げばかりで＞はいつまでも身につきませんよ。
→おっしゃるとおりです。
身にしみました。本当にありがとうございました。

回答No.9

hofuhofu

VBAでは無くて、VBSですが。
以下のソースをメモ帳などに貼り付けて拡張子をvbsとして保存します。
C:\新規Microsoft Excel ワークシート(?).xlsの各シートのB列をC:\Target.xlsの同名のシートに集めるようになっています。
ファイル名は環境にあわせて適当に変えてください。

Const DstFileName = "C:\Target.xls"

Dim SrcFileName
Dim objXlsApp
Dim objDstXls
Dim objSrcXls
Dim objDstSht
Dim objSrcSht

Dim DstXlsList(4)
DstXlsList(0) = "C:\新規Microsoft Excel ワークシート.xls"
DstXlsList(1) = "C:\新規Microsoft Excel ワークシート (2).xls"
DstXlsList(2) = "C:\新規Microsoft Excel ワークシート (3).xls"
DstXlsList(3) = "C:\新規Microsoft Excel ワークシート (4).xls"
DstXlsList(4) = "C:\新規Microsoft Excel ワークシート (5).xls"

Set objXlsApp = CreateObject("Excel.Application")
Set objDstXls = objXlsApp.Workbooks.Open(DstFileName)

For Each SrcFileName In DstXlsList
Set objSrcXls = objXlsApp.Workbooks.Open(SrcFileName)

For Each objSrcSht In objSrcXls.Worksheets
Set objDstSht = FindSheet(objDstXls, objSrcSht)
If objDstSht Is Nothing Then
Set objDstSht = objDstXls.Worksheets.Add
objDstSht.Name = objSrcSht.Name
End If

CopyDataColumn objSrcSht, objDstSht
Next
objSrcXls.Close
Next

objDstXls.Close True, objDstXls.FullName
objXlsApp.Quit

Private Function FindSheet(objDstXls, objSrcSht)
Dim objDstSht

For Each objDstSht In objDstXls.Worksheets
If objDstSht.Name = objSrcSht.Name Then
Set FindSheet = objDstSht
Exit Function
End If
Next

Set FindSheet = Nothing
End Function

Private Sub CopyDataColumn(objSrcSht, objDstSht)
Dim objDstCell
Dim objSrcCell

Set objDstCell= objDstSht.Range("B2")
While objDstCell.Value <> ""
Set objDstCell = objDstCell.Offset(0, 1)
Wend

Set objSrcCell = objSrcSht.Range("B2")
While objSrcCell <> ""
objDstCell.Value = objSrcCell.Value
Set objSrcCell = objSrcCell.Offset(1, 0)
Set objDstCell = objDstCell.Offset(1, 0)
Wend
End Sub

蛇足ですがイミディエイトウインドウはVBAでは基本の分野にあたります。
インターネット等で調べてみるだけでなく、初期のうちは本を読むなどしたほうが理解がスムーズに行くと思います。

お礼

ご丁寧にありがとうございます
やってみます

回答No.8

yokomaya

○ファイル１に戻り
の部分は
Windows("ファイル１").Activate
みたいな記録かと思いますが
内側のループにするとコピーの前に
Windows("ファイル２").Activate
で戻す必要があることを忘れてました。
勿論ファイル２と直接かくのではなく
Range("J"&j)です。
あれ？さっきはRange("J"&i)って書いちまった。間違いです。Range("J"&j)ね。

このjを用いて貼り付け位置をずらすには
Range("C2").select
が記録された内容なら
Cells(2,2+j).select
と変更すればjの変化に応じて右にひとつずつ
ずれていきます。

まだ説明足りないとは思うけどとりあえず試してみていただけます？

お礼

イミディトのところに、、?thisworkbook.worksheets(1).name
と記入しましたが。・そのあと、どうすればよいのです？？

回答No.7

yokomaya

初めて聞きましたか。なるほど。僕は直接確かめるのによく使います。プログラム中もデバッグの途中でブレークポイントを指定して止めて色々な状態を確認したり出来ますし。それはさておき、?thisworkbook.worksheets(1).nameで一番目のシート名がでますよね。()の中の数字を変えるとその他のシート名も得られます。
ということは、最初の目的のシートを選択の前にループの為に
for i=1 to 5
として最後のファイル２を閉じる前に
next
を置くと５回ループしますから、
その間でシートを選ぶときに、直接シート名をうつ代わりに

thisworkbook.worksheets(i).name
を使うとiが自動的に１から５まで変わっていくのでシート名も期待通りに変化してくれるのです。

ところで手作業ではコピーに際してシートを選択してセルを選択してそれをコピーしますがプログラムの場合は全部くっつけちゃう方が合理的で無駄がありません。
例えば
Sheets("Sheet3").Select
Range("B2:B4").Select
Selection.Copy
ならば
Sheets("Sheet3").Range("B2:B4").Copy
みたいにです。
（勿論この"Sheet3"の処は前述の().nameを使うんですよ。）

貼り付けのほうはそうは行きませんので。
selectのままでいいです。
ただ貼り付け場所がずれていかなければなりませんよね。それにはブックで用いるループの変数に応じてひとつずつ右にずれるということでよいのかな、多分。
ブックで用いるループは全体の外側に
つまり先頭に
for j=1 to 4
と最終行に
next
を入れます。
ファイル２からファイル５までのブックの名前を
４個シートの使わない部分に並べます。
例えば J1からJ4に並べたとすればファイル２を開いたマクロの記録部分で"ファイル２"の代わりにRange("J"&i)を使うと順次ブック名が割り当てられます。

お礼

難しいですね。。
ちょっとついてけそうにないです・・

回答No.6

yokomaya

全てのブックのシート名が共通との事ですからファイル１のシート名をそのまま使う事で実現します。ＶＢＥを開いてイミディエイトに?thisworkbook.worksheets(1).nameと打ってみて下さい。今携帯からなので続きは家から打ちます。

お礼

お世話になります.イミディエイトウィンドウは初めて聞く単語でしたので、ネットで調べておりました・。・。・
続きをどうかよろしくお願いいたします

回答No.5

yokomaya

これくらいは知っているというのはループ処理とかのことで良いですか。僕が示したのは１箇所分だけなので後の４回×ファイル５本分はループ処理で行う様に記述していく予定で考えているのですが、説明についてこれるという意味と考えてよろしいでしょうか？ソースは示しませんので変更すべき点を説明したいとおもいますが。

お礼

ループ処理は以前組んだことがありますので、分かるのですが。。
複数のブックから、同じシート名のＤＡＴＡを集めるというのが、どうしたらいいか？？です・・
お教え願いたら幸いです

回答No.4

yokomaya

貴方はＶＢＡをどれくらい理解されているでしょう？けして難しい話しではなくマクロの記録とそれの構文が読めれば、数箇所の記述と変更で実現は出来ます。
ファイル１にまとめるのですからまずファイル１だけを開いた状態でマクロの記録を開始します。
○ファイル２を開き
○目的のシートを選択
○コピーしたい範囲を選択
○コピー
○ファイル１に戻り
○目的のシートを選択
○貼付け位置を選択して
○貼付け
○ファイル２を閉じます。
マクロの記録を終了します。
これを修正していくのですが、変数、ループ処理、配列が理解できないと以下説明しても意味がないのでとりあえずここまで。

お礼

これくらいは知っています、数が多いので、マクロの記録は時間がかかるのと思っています、
同じシート名のデータを集めるということで苦労しています。

回答No.3

zap35

＃０１です。

=[Book3.xls]Sheet1!$B$5
のようにすれば他のブックのセル参照式になります。

先の質問も拝見しましたが、今回の質問は「各ブック、各シートのＢ列の値をそっくりコピーしたい」という意味なら、先の回答を少し直せば可能ですよ。

お礼

＞ブック、各シートのＢ列の値をそっくりコピーしたい
同じシート毎に、Ｂ列を集めたいのですが。。

回答No.2

noname#22222

ウーン！質問の都度、やりたい事が変化しているようで・・・。
データをCSVファイルで吐き出すとして・・・。

1,2,3,4
1,2,3,4
1,2,3,4

という<datas.csv>ファイルを仮定します。

これを、1列目をb1.xlsに、2列目をc1.xlsに、4列目をe1.xlsに書き込むコードは次のようです。
回答のコードを多少いじれば、複数のブックにデータを振り分けることが可能でしょう。

注意１: datas.csv は、カレントディレクトリに置いて下さい。
注意２: microsft runtime script を参照するように設定して下さい。

一応、テスト済みです。

Private Sub CommandButton1_Click()
　　Dim bkName
　　Dim I　　　　 As Integer
　　Dim J　　　　 As Integer
　　Dim K　　　　 As Integer
　　Dim N　　　　 As Integer
　　Dim xlApp　　 As Object
　　Dim xlBook(3) As Object
　　Dim Datas()　 As String
　　Dim Data()　　As String

　　' -----------------------------
　　'　bkName() にブック名をセット
　　' -----------------------------
　　bkName = Array("C:\Temp\b1.xls", "C:\Temp\c1.xls", "C:\Temp\d1.xls", "C:\Temp\e1.xls")
　　' ---------------------------------
　　'　Datas() に datas.csv を読み込む
　　' ---------------------------------
　　' 注意: datas.csv はカレントディレクトリに存在すること
　　'
　　Datas() = FileReadArray("datas.csv")
　　N = UBound(Datas())
　　' ------------------
　　'　ブックをオープン
　　' ------------------
　　Set xlApp = CreateObject("Excel.Application")
　　Set xlBook(0) = xlApp.Workbooks.Open(bkName(0))
　　Set xlBook(1) = xlApp.Workbooks.Open(bkName(1))
　　Set xlBook(2) = xlApp.Workbooks.Open(bkName(2))
　　Set xlBook(3) = xlApp.Workbooks.Open(bkName(3))
　　' --------------
　　'　ブックを更新
　　' --------------
　　For J = 0 To N
　　　　Data() = Split(Datas(J), ",")
　　　　If UBound(Data()) = 3 Then
　　　　　　K = J + 1
　　　　　　xlBook(0).Sheets(1).Cells(K, 1) = Data(0)
　　　　　　xlBook(1).Sheets(1).Cells(K, 1) = Data(1)
　　　　　　xlBook(2).Sheets(1).Cells(K, 1) = Data(2)
　　　　　　xlBook(3).Sheets(1).Cells(K, 1) = Data(3)
　　　　End If
　　Next J
　　' --------------
　　'　ブックを保存
　　' --------------
　　xlBook(0).Close True, bkName(0)
　　xlBook(1).Close True, bkName(1)
　　xlBook(2).Close True, bkName(2)
　　xlBook(3).Close True, bkName(3)
　　' --------------
　　'　xlApp を破棄
　　' --------------
　　Set xlApp = Nothing
End Sub

Public Function FileReadArray(ByVal FileName As String) As String()
On Error GoTo Err_FileReadArray
　　 Dim fso　　　　As FileSystemObject
　　 Dim fil　　　　As File
　　 Dim txs　　　　As TextStream
　　 Dim strText　　As String
　　 Dim strTexts() As String

　　 Set fso = New FileSystemObject
　　 Set fil = fso.GetFile(FileName)
　　 Set txs = fil.OpenAsTextStream(ForReading, TristateUseDefault)
　　 strText = txs.ReadAll
　　 strTexts = Split(strText, Chr$(13) & Chr$(10))
Exit_FileReadArray:
　　 FileReadArray = strTexts()
　　 Exit Function
Err_FileReadArray:
　　 MsgBox Err.Description & "(FileReadArray)", vbExclamation, " 関数エラーメッセージ"
　　 strTexts() = Split("")
　　 Resume Exit_FileReadArray
End Function

※Excelは操作したことがない単なるスーツのデザイナーです。
※VBA を使えば簡単ですが、私の回答を読めないと少しシンドイです。
※Excelの機能を駆使して手作業が早いような気もします。

回答No.1

zap35

ＶＢＡを書いてくださいという依頼ですか？
でも集めてくるセルの範囲、マクロを実行するときの前提（BOOKは開いているかどうか）、BOOK名、BOOKのパス、などが明記されていないので、コードも書きようがありません。

それらをあれこれ想像して作っても質問者さまが修正しなければ使い物にならないでしょう。質問者さまがマクロを掲載して「どう直せばよいか？」お聞きになるのであれば、お答えもできますが…

代替案ですが、エクセルでは複数のBOOKにまたがってセル参照が可能ですから、その方法を用いる方が簡単ではありませんか？

お礼

すいません、ＶＢＡをイメージしていおりました。
VBAを使わなくともできる方法として、セル参照というのがあるのですね？教えてくだされば幸いです。