[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ファイル結合の際に1行目を削除する』(ももんが)
こんにちは。
月毎の同じ内容の複数のファイルを結合するマクロを手に入れました。
(自分で作成はしておりません)
各ファイルの1行目は見出しになっています。
2つ目のファイルからは1行目を削除して結合したいのですが、その方法を教えて頂ければと思います。
よろしくお願い致します。
Sub merge()
'シート[merge]を削除
On Error Resume Next Application.DisplayAlerts = False Worksheets("merge").Delete Application.DisplayAlerts = True
'シート[merge]を一番右に追加
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "merge"
'フォルダの場所を変数に入れる
Dim Folder_path Folder_path = ThisWorkbook.Worksheets("folder").Range("b2").Value
'結合するブックを変数に入れる
Dim FileType If Worksheets("folder").Range("b1").Value = "Excel" Then FileType = "\*.xls*" Else FileType = "\*.csv" End If
Dim MergeWorkbook MergeWorkbook = Dir(Folder_path & FileType)
'指定したフォルダから、ファイルを探して、開いてコピペ
Do Until MergeWorkbook = "" Workbooks.Open Filename:=Folder_path & "\" & MergeWorkbook
Dim MergeWorkbook_data '結合するブック内のシートのデータ数 Dim ThisWorkbook_data '結合先のシートのデータ数
Dim i For i = 1 To Workbooks(MergeWorkbook).Worksheets.Count
MergeWorkbook_data = Workbooks(MergeWorkbook).Worksheets(i).Range("a" & Rows.Count).End(xlUp).Row ThisWorkbook_data = ThisWorkbook.Worksheets("merge").Range("a" & Rows.Count).End(xlUp).Row
Workbooks(MergeWorkbook).Worksheets(i).Rows("1:" & MergeWorkbook_data).Copy ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1) Next
'結合するブックを閉じる Application.DisplayAlerts = False Workbooks(MergeWorkbook).Close Application.DisplayAlerts = True
'次のブックを探しに行く
MergeWorkbook = Dir() Loop
End Sub
< 使用 Excel:Excel2013、使用 OS:Windows10 >
>月毎の同じ内容の複数のファイルを結合するマクロを手に入れました。
>(自分で作成はしておりません)
月ごとかどうかわかりませんが、指定したフォルダに保存されているファイルのうち
「*.xls*」(「*.csv」モードに切り替えられる機能付き)を片っ端から開いて、開いたブックの各シートをマクロが記述されているブックの「merge」というシートに累積コピーさせていくコードに見えます。
その上で確認ですけど、質問者さんが結合したいのは、Excelブックということでよいですか?
(CSVなら、ブックとして開くのではなく、メモリ上に読み込んで結合する方法や、外部データの取込で対応する方法があるとおもうので・・・)
また、手に入れられたコードはどこまで理解できていますか?
・Dir関数でファイル検索してるんだな〜 ・Rows.Count.End(xlUp).Rowで最終行を調べているんだな〜 ・COPYメソッドでブック間のコピペをやってるんだな〜
なんてところはピンときてますか?
気になる部分はいくつかありますけど、質問にだけ答えるなら
ThisWorkbook_data = ThisWorkbook.Worksheets("merge").Range("a" & Rows.Count).End(xlUp).Row Workbooks(MergeWorkbook).Worksheets(i).Rows("1:" & MergeWorkbook_data).Copy _ ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1)
↓
ThisWorkbook_data = ThisWorkbook.Worksheets("merge").Range("a" & Rows.Count).End(xlUp).Row
If ThisWorkbook_data = 1 Then Workbooks(MergeWorkbook).Worksheets(i).Rows("1:" & MergeWorkbook_data).Copy _ ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1) Else Workbooks(MergeWorkbook).Worksheets(i).Rows("2:" & MergeWorkbook_data).Copy _ ThisWorkbook.Worksheets("merge").Range("a" & ThisWorkbook_data + 1)
のように、貼付先になっているシートの最終行が1行目でなければ、2行目以降をコピーするようにしちゃうのもひとつの手だとおもいます。
(もこな2) 2018/08/09(木) 20:07
Sub 研究用() Dim フラグ As Boolean Dim dstSH As Worksheet Dim dstRNG As Range, srcRNG As Range Dim MyFolder As String, MyFile As String Dim tmp As Worksheet
Stop
'FileDialogオブジェクトでフォルダを選択させる With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then MyFolder = .SelectedItems(1) If MyFolder = "" Then Exit Sub End If End With
Set dstSH = ThisWorkbook.Worksheets("まとめ") dstSH.Cells.Clear
Set dstRNG = dstSH.Range("A1")
MyFile = Dir(MyFolder & "\*.xls*") Do Until MyFile = "" With Workbooks.Open(MyFolder & "\" & MyFile) For Each tmp In .Worksheets Set srcRNG = Intersect(tmp.UsedRange, tmp.UsedRange.Offset(Abs(フラグ))) If Not srcRNG Is Nothing Then srcRNG.Copy dstRNG Set dstRNG = dstSH.Cells(dstSH.UsedRange.Rows.Count, "A") フラグ = True End If Next .Close End With
MyFile = Dir() Loop
End Sub
(もこな2) 2018/08/09(木) 23:15
Set dstRNG = dstSH.Cells(dstSH.UsedRange.Rows.Count, "A") ↓ Set dstRNG = dstRNG.Offset(dstSH.UsedRange.Rows.Count)
に修正してください。
(もこな2) 2018/08/09(木) 23:21
ご回答をありがとうございました。
私のレベルはマクロの記録を改修して、selectだらけのものを作成する程度です。
(この部分はたぶん○○をしているんだな程度で、理解をしているとは言えません)
もこな2様のおっしゃる通り、片っ端から開いて、開いたブックの各シートをマクロが記述されているブックの「merge」というシートに累積コピーさせていくコードです。
ExcelとCSV、どちらも使用します。
教えて頂いた部分を変更してうまくいきました。
研究用もありがとうございました。
研究用の方ですが、
Set dstRNG = dstSH.Cells(dstSH.UsedRange.Rows.Count, "A") ↓ Set dstRNG = dstRNG.Offset(dstSH.UsedRange.Rows.Count)
両方を試したところ、どちらも出来たのですが、下の方は例えば4月分と5月分の間に空白行が入っていました。(データに変な空白行があるのだと思います)
上の方でも問題はないと捉えて良いのでしょうか。
(ももんが) 2018/08/10(金) 09:48
コピー元のほうは、1行目からデータが始まってることが前提となりますが、こんな感じではどうですか?
(ついでに、後で調べられるようにどのブック、どのシートからコピーしてきたのか情報を付けるように改造)
Sub 研究用2() Dim フラグ As Boolean
Dim srcSH As Worksheet, srcRNG As Range, srcROW As Long Dim dstSH As Worksheet: Set dstSH = ThisWorkbook.Worksheets("まとめ")
Dim MyFolder As String, MyFile As String
Stop
'FileDialogオブジェクトでフォルダを選択させる With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then MyFolder = .SelectedItems(1) If MyFolder = "" Then Exit Sub End If End With
dstSH.Cells.Clear
MyFile = Dir(MyFolder & "\*.xls*") Do Until MyFile = "" With Workbooks.Open(MyFolder & "\" & MyFile)
'あえて1回だけ項目行のみコピー If Not フラグ Then .Worksheets(1).UsedRange.Rows(1).Copy dstSH.Cells(1, "C") dstSH.Range("A1:B1").Value = Array("ブック名", "シート名") フラグ = True End If
'ブック内の各シートをまとめシートにコピペ For Each srcSH In .Worksheets
'コピー元の最終行を取得 srcROW = srcSH.Cells(srcSH.Rows.Count, "A").End(xlUp).Row
If srcROW > 1 Then 'コピー元の最終行が1行目でなければ(データがあれば)「srcRNG」にコピー範囲をセット Set srcRNG = Intersect(srcSH.UsedRange.EntireColumn, srcSH.Rows(2 & ":" & srcROW)) Debug.Print .Name & " ブックの "; srcRNG.Parent.Name & " シートの "; srcRNG.Address(0, 0) & " をコピー"
With dstSH.Cells(dstSH.Rows.Count, "C").End(xlUp).Offset(1) .Cells.Offset(, -2).Resize(srcRNG.Rows.Count).Value = srcSH.Parent.Name .Cells.Offset(, -1).Resize(srcRNG.Rows.Count).Value = srcSH.Name srcRNG.Copy .Cells End With End If Next srcSH
.Close End With
MyFile = Dir() Loop
End Sub
(もこな2) 2018/08/10(金) 19:50
ご教授ありがとうございました。
また、研究用2もありがとうございました。
コピー元の情報が入るのはすごく助かります。
これを元に他のものに応用したいと思います。
お忙しい中、ありがとうございました。
(ももんが) 2018/08/13(月) 11:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.