エクセルファイルの一部を一つにまとめたいのです。

質問

初めて質問いたします。Excelファイル(Excel ver.2000)が1000弱あり、その中の一部の列をコピーし、行と列を入れ替えてペーストして、一つのファイルにまとめたいと考えています。（一つのファイルに1000行弱が並ぶイメージです）
過去の質問を検討して、ソフト等も使ってみましたが、意外にできず、マクロを組めば簡単にできそうなことはイメージできたのですが、行動履歴機能を使ってみてもいまいちうまくできません。特にファイルを1-1000まで指定する方法がわからず、このままだと全て番号の手打ち＆ペーストになりそうな気配です。
どのようにすれば良いか、どうか教えて下さい！

回答No.4

merlionXX · ベストアンサー

そのエラーはたぶん、集計されるファイルが見つからなかったためだと思います。

1.集計されるファイルの集計されるシート名はすべてSheet1。
2.集計されるファイルの集計部分はすべてG3-G19のみ。
3.集計するファイル（このマクロを書くファイル）のSheet1のA1以降に転記する。
4.集計するファイル（このマクロを書くファイル）は集計されるファイルと同一のフォルダー内に置く。

以上の前提で

Sub TEST01()
Dim n As Integer
Dim mb As Workbook, wb As Workbook
Dim myfdr As String, fname As String
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = mb.Path '自分のフォルダー名を取得
fname = Dir(myfdr & "\*.xls") '同一フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If Val(Left(fname, 4)) >= 1000 And Val(Left(fname, 4)) <= 1974 Then 'ブック名の左4文字が1000から1974ならば
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
n = n + 1 'ブック数をカウントしnとする
wb.Sheets("Sheet1").Range("G3:G17").Copy 'Sheet1のG3:G17データをコピー
mb.Sheets("Sheet1").Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'mbのn行目に横に貼り付け
Application.CutCopyMode = False
wb.Close (False) '開いたBookを保存の有無を聞かずに保存しないで閉じる
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
MsgBox n & "件のブックをコピーしましました。"
End Sub

ではいかがでしょう？

お礼

できました！！！

本当にありがとうございます。

ファイルが自動で開いたり閉じたりするのを眺めてしまいました。
マクロの威力はすごいですね。

これを機会に少しずつ勉強していきたいと思います。
解説つきのマクロ、どうもありがとうございました。

それでは、失礼いたします。

回答No.3

merlionXX

お書きになった質問だけでは情報不足なので以下の前提で回答します。

集計されるファイルの集計されるシート名はすべてSheet1だとします。
集計される列はA列とし、A1から下へ連続しているものとします。（ただし256行まで）
集計するファイル（このマクロを書くファイル）のSheet1のA1以降に転機するものとします。

同じフォルダーにおいた集計するファイルの標準モジュールに以下のコードを記入して実行してみてください。

Sub TEST01()
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If Val(Left(fname, 4)) >= 1000 And Val(Left(fname, 4)) <= 1974 Then 'ブック名の左4文字が1000から1974ならば
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
n = n + 1 'ブック数をカウントしnとする
wb.Sheets("Sheet1").Range(Range("A1"), Range("A1").End(xlDown)).Copy 'Sheet1のA1以下の連続データをコピー
mb.Sheets("Sheet1").Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'mbのn行目に横に貼り付け
Application.CutCopyMode = False
wb.Close (False) '開いたBookを保存の有無を聞かずに保存しないで閉じる
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
MsgBox n & "件のブックをコピーしましました。"
End Sub

補足

どうもありがとうございました！
前提の件一点、自分の説明不足で、
・G3-G19に値が縦に並んでいます。(G7のみ空欄）

頂いたマクロ、早速実行してみましたが、

実行時エラー'1004':
RangeクラスのPasteSpecialメソッドが失敗しました。

としてエラーがでてしまいます。
mb.Sheets("Sheet1").Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'mbのn行目に横に貼り付け
の部分に問題があるとのことで、1行目から貼り付けとしたかったので
mb.Sheets("Sheet1").Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'mbのn行目に横に貼り付け
としてみましたが、やはり上記エラーは変わらずでした。

もしかして、Excelのバージョンの問題なのでしょうか？
度々で大変恐縮ですが、ご教授願えれば嬉しいです。

回答No.2

picopico_7

行と列を入れ替えて貼り付けたいとのことであればコピー対象部分をコピーした後、貼り付ける時に「行と列を入れ替えて貼り付け」そしてあげれば良いかと思います。

貼り付け作業
1.メニューバー[編集]→[形式を選択して貼り付け]
2.形式を選択して貼り付けダイアログボックスの下にある[行列を入れ替える]にチェックを入れてOK

お礼

どうもありがとうございます。
すみません、上記については存じておりました。説明不足で恐縮です。
これを1000回繰り返せばいいのですよね。。

今後もファイル数が増えていくことを考えて、この際これをきっかけにマクロを勉強してみようと思って質問させていただきました。

どうもありがとうございました。

回答No.1

imogasi

もうそんな答えはどこかで見たでしょうが、
（１）エクセルは基本は手作業で操作をする体系で組み立てられています。
（２）手作業を繰り返すのが不可能というなら、プログラムの力で繰り返し作業に持ち込んでやらせるしかありません。勉強してください。
なんか良い方法ガひょっとしてあるのでは、と思うのは幻想です。何度質問しても同じです。
あればレディメードのソフトを探すのが一番良いですが。
ーー
＞特にファイルを1-1000まで指定する方法がわからず
判らないといウだけでは、回答者にも判るはずがない。質問者の
問題にしているファイルの
（１）所在フォルダが１つにまとまっているや
（２）ブックの名前の命名に他と区別できる特徴があるとか
（３）連番が名前の一部に入っているとか
そういうことを関心を持って１０００個分について整理し、質問で説明しないと、誰も答えられません。
ＶＢＡも勉強しないで１０００個も野放図にブックを作っておいて、データの組み換えをいまさらしたいなどということが、無理なんです。
こまめにまとめなどやっておくとか色々見通しておかないと。

補足

回答ありがとうございます。

1) 所在フォルダは一つにまとまっています
2)3) ブックの命名は「1xxx○○○.xls」となっています
※ xxxは半角数字で1000-1974まで　○○○は漢字で文字数は不定

以上です。よろしくお願いいたします。