[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダ内のエクセルの複数セルを別の一つのエクセル内にまとめたい』（みかん）
１・とあるフォルダの中にいくつかのAエクセルがある。
（Aエクセルは、一つのフォルダ内にいくつかありファイル名もバラバラ）
２・このAエクセル内にある複数セルを別フォルダにあるBエクセルのセルにコピー。
（複数のAエクセルのセル内容を一つのBエクセルに上から順にリスト化していくイメージ。）
３・同時にAエクセルと同じ数だけCエクセルにコピー
（Aエクセルひとつずつにつき、Cエクセルも同様にひとつずつ必要。フォーマットになっているCエクセル様式の空欄をAエクセルからコピーして埋めていきたいイメージ。）
上記のような処理を行いたいのですが、どのように書けばよいのでしょうか。
最終的に１→２のパターンと、１→３のパターンが出来れば、処理するベースのエクセルが二つになったりしても構いませんが、一括で出来ると嬉しいです。
以上、難しい内容だと思うのですが、何卒アドバイス等頂けると助かります。
よろしくお願いいたします。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
まくろスタート
[とあるフォルダ]を巡回
もしも、Excelブックだったら開く[Aブック]
[Bブック]の出力シートの最終行の1行下に、開いたブックを書き込み
[Cブック]を開いて該当シートに書き込む
[Cブック]を"別名で"保存して閉じる
[Aブック]を"保存せずに"閉じる
もしもの話ここまで
巡回の話ここまで
まくろ終わり
もし、手を付けているものがあるなら、完成していなくても提示頂くとアドバイスできる部分があるかもしれません。
（もこな２ ） 2020/04/27(月) 09:35
・「エクセル＝ブックと解釈して」
そのとおり、ブックです。
・「手を付けているものがあるなら」
このマクロの流れをイメージ出来なかったので未だ手を付けていない状況です。
（みかん） 2020/04/27(月) 11:01
'Aフォルダを巡回
Dim path, fso, file, files
path = "D:\D\ドキュメント\A"
Set fso = CreateObject("Scripting.FileSystemObject")
Set files = fso.GetFolder(path).files
'フォルダ内の全ファイルについて処理
For Each file In files
'ファイルを開いてブックとして取得
Dim wb As Workbook
Set wb = Workbooks.Open(file)
'Bブックの出力シートの最終行の1行下に､開いたブックを書き込み
'Cブックを開いて該当シートに書き込む
'Cブックを"別名で"保存して閉じる
' [Aブック]を"保存せずに"閉じる
Call wb.Close(SaveChanges:=False)
Next file
End Sub
現況こんな形になりましたが、どうでしょうか。
（みかん） 2020/04/27(月) 17:13
Sub OpenFilesInFolder()
'Aフォルダを巡回
Dim path, fso, file, files
path = "D:\D\ドキュメント\A"
Set fso = CreateObject("Scripting.FileSystemObject")
Set files = fso.GetFolder(path).files
'フォルダ内の全ファイルについて処理
For Each file In files
'ファイルを開いてブックとして取得
Dim wb As Workbook
Set wb = Workbooks.Open(file)
With Workbooks.Open(f.path)
'Bブックの出力シートの最終行の1行下に､開いたブックを書き込み
Dim staffPP As String: staffPP = .Range("F7").Value '2 部署
Dim staffName As String: staffName = .Range("C15").Value '3 氏名
Dim pcid As Long: pcid = .Range("A15").Value '4 機器ID
Dim inday As Date: inday = .Range("C18").Value '5 in日
Dim outday As String: outday = .Range("F18").Value '6 out日
Dim i As Long: i = 15
Do While .Cells(i, 1).Value <> ""
wsData.Cells(di, 2).Value = staffPP '2 部署
wsData.Cells(di, 3).Value = staffName '3 氏名
wsData.Cells(di, 4).Value = pcid '4 機器ID
wsData.Cells(di, 5).Value = inday '5 in日
wsData.Cells(di, 6).Value = outday '6 out日
i = i + 1: di = di + 1
Loop
End With
'Cブックを開いて該当シートに書き込む
'Cブックを"別名で"保存して閉じる
' [Aブック]を"保存せずに"閉じる
Call wb.Close(SaveChanges:=False)
Next file
End Sub
（みかん） 2020/05/06(水) 20:36
おかしいな？とおもったら、まずはステップ実行をして自己検証してみてください。
それがデバッグ作業というものです。
ちなみに、宣言していない「f」「wsData」をいきなり使ってますが、最低限そこは直さないとダメでしょう。
さらに、↓のようにしていますが足りないものがありませんか？
With Workbooks.Open(f.path)
staffPP = .Range("F7").Value
ヒント：セルは何に属してますか？
ワークブック
┗ワークシート
┗セル
（もこな２） 2020/05/07(木) 07:59
コンパイルエラーにならないことしかチェックしてないですが、そこまで変数てんこ盛りにしなくてもよさそうな気がします。
Sub さんぷる()
Const とあるフォルダ As String = "D:\D\ドキュメント\A"
Dim Aブック As Workbook
Dim 出力行 As Long
Dim ファイル As Object
Stop '←ブレークポイントの代わり
出力行 = 15
For Each ファイル In CreateObject("Scripting.FileSystemObject").GetFolder(とあるフォルダ).Files
If ファイル.Name Like "*.xls?" Then
Set Aブック = Workbooks.Open(ファイル.Path)
'▼Ｂブックに書き込む
With ThisWorkbook.Worksheets("出力")
.Cells(出力行, 2).Value = Aブック.Worksheets(1).Range("F7").Value '2 部署
.Cells(出力行, 3).Value = Aブック.Worksheets(1).Range("C15").Value '3 氏名
.Cells(出力行, 4).Value = Aブック.Worksheets(1).Range("A15").Value '4 機器ID
.Cells(出力行, 5).Value = Aブック.Worksheets(1).Range("C18").Value '5 in日
.Cells(出力行, 6).Value = Aブック.Worksheets(1).Range("F18").Value '6 out日
End With
出力行 = 出力行 + 1
'▼Ｃブックの処理
With Workbooks.Open("D:\ほにゃほにゃ\フォーマット.xls")
'Aブックの内容を書き込む
.Worksheets(1).Range("F7").Value = Aブック.Worksheets(1).Range("F7").Value '2 部署
.Worksheets(1).Range("C15").Value = Aブック.Worksheets(1).Range("C15").Value '3 氏名
.Worksheets(1).Range("A15").Value = Aブック.Worksheets(1).Range("A15").Value '4 機器ID
.Worksheets(1).Range("C18").Value = Aブック.Worksheets(1).Range("C18").Value '5 in日
.Worksheets(1).Range("F18").Value = Aブック.Worksheets(1).Range("F18").Value '6 out日
'別名で保存して閉じる
.SaveAs _
Filename:="D:\ほにゃほにゃ\" & Format(出力行 - 15, "000")
.Close
End With
'Ａブックを保存せずに閉じる
Aブック.Close False
End If
Next ファイル
End Sub
（もこな２） 2020/05/07(木) 08:31
幾度もの質問に丁寧に回答頂いて大変助かりました。
参考に作成させていただいたところ、予定していた動作をするようになりました。
感謝いたします。
ありがとうございました。
（みかん） 2020/05/10(日) 13:04
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.