[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数ファイルを1個のファイルにまとめる方法』(イチゴパフェ)
複数ファイルを1個のファイルにまとめる方法
下記のマクロは複数Excelを1個のExcelにまとめるのに使用してます。
Sub 送状抽出は、普段別に使用しているマクロになります。
「送*状」を含むデータだけを抽出したくて途中に入れました。
しかし、データ自体は取得できるのですが
なぜか、1個目・2個目・3個目と張り付く行に空きができてしまいます
空く行数は平野用*.xlsxに元々ある行数分だけ空いてしまいます。
「送状抽出」を入れないで行えばそのままキレイに張り付きますがそれだとデータ重いので処理が止まってしまいます。
なぜそのような現象が起こるか分かる方が居ましたら助けて下さい。
Sub 五ファイル貼付()
Application.ScreenUpdating = False
Dim desktop As String Dim ds As Worksheet Dim dr As Long Dim file As String Dim wb As Workbook Dim ws As Worksheet Dim lastRow As Long desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" Set ds = ThisWorkbook.Sheets("Sheet2") '貼り付け先シート ds.Cells.ClearContents '結果クリア dr = 1 'コピー先行の初期値=1 file = Dir(desktop & "平野用*.xlsx") Do While file <> "" Set wb = Workbooks.Open(desktop & file) Set ws = wb.Sheets("Sheet1") 送状抽出 lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("1:" & lastRow).Copy ds.Range("A" & dr) dr = dr + lastRow wb.Close False file = Dir Loop End Sub
Sub 送状抽出()
Dim 検索文字 As String, 記憶 As String
記憶 = "送*状"
If IMEStatus = vbIMEModeOff Then
SendKeys "{kanji}", True End If 検索文字 = 記憶 記憶 = 検索文字 検索文字 = StrConv(検索文字, vbWide) 検索文字 = Application.WorksheetFunction.Substitute(検索文字, "*", "*") Selection.AutoFilter Field:=36, Criteria1:="*" & 検索文字 & "*" End Sub
< 使用 Excel:Microsoft365、使用 OS:Windows10 >
もとのコードを生かすならdrの行番号を、dsシートの最終行の次の行に指定することで行けそうな気がするけど、どうかな? コピー元の先頭行が空白じゃない限り大丈夫だと思うけど・・・ Sub 五ファイル貼付() Dim desktop As String Dim ds As Worksheet Dim dr As Long Dim file As String Dim wb As Workbook Dim ws As Worksheet Dim lastRow As Long desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" Set ds = ThisWorkbook.Sheets("Sheet2") '貼り付け先シート ds.Cells.ClearContents '結果クリア dr = 1 'コピー先行の初期値=1 file = Dir(desktop & "平野用*.xlsx") Application.ScreenUpdating = False Do While file <> "" Set wb = Workbooks.Open(desktop & file) Set ws = wb.Sheets("Sheet1") Call 送状抽出 lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row If dr > 1 Then dr = ds.Cells(Rows.Count, "A").End(xlUp).Offset(1) End If ws.Range("1:" & lastRow).Copy ds.Range("A" & dr) wb.Close False file = Dir Loop Application.ScreenUpdating = True End Sub (稲葉) 2023/01/13(金) 15:10:21
Sub 修正案() Dim ds As Worksheet Dim desktop As String Dim file As String Dim buf As Long Dim フラグ As Boolean
Set ds = ThisWorkbook.Sheets("Sheet2") '貼り付け先シート ds.Cells.ClearContents
desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
file = Dir(desktop & "平野用*.xlsx") Do While file <> "" With Workbooks.Open(desktop & file).Sheets("Sheet1") .AutoFilterMode = False .Range("A1").AutoFilter Field:=36, Criteria1:="*送*状*"
buf = ds.Cells(ds.Rows.Count, 37).End(xlUp).Row + 1
Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(フラグ * -1)).Copy ds.Cells(buf, "B") ds.Range(ds.Cells(buf, "A"), ds.Cells(ds.Cells(ds.Rows.Count, 37).End(xlUp).Row, "A")).Value = file
.Parent.Close False フラグ = True End With
file = Dir() Loop
ds.Rows(1).Delete End Sub
(もこな2) 2023/01/13(金) 15:39:43
buf = ds.Cells(ds.Rows.Count, 37).End(xlUp).Row + 1 Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(フラグ * -1)).Copy ds.Cells(buf, "B") ds.Range(ds.Cells(buf, "A"), ds.Cells(ds.Cells(ds.Rows.Count, 37).End(xlUp).Row, "A")).Value = file .Parent.Close False
これはどういった処理なのでしょうか?
(イチゴパフェ) 2023/01/16(月) 14:59:33
■2
>これはどういった処理なのでしょうか?
こちらも【ステップ実行】して確認された方がよいと思いますが、それぞれ
====================================================== buf = ds.Cells(ds.Rows.Count, 37).End(xlUp).Row + 1 ↓ 【buf】という変数に、 ThisWorkbook.Sheets("Sheet2")のAK1048576セルから上に見ていき、 最初にデータが入っている行の行番号+1を格納しなさい ====================================================== Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(フラグ * -1)).Copy 〜〜 ↓ オートフィルタが設定されているセル範囲と、オートフィルタが設定されているセル範囲(から1行下がった)セル範囲が 重なる範囲(=項目行を除いた、オートフィルタが設定されているセル範囲)をコピーしなさい ====================================================== 〜〜 ds.Cells(buf, "B") ↓ ThisWorkbook.Sheets("Sheet2")のB列、[buf]行目に貼付しなさい ====================================================== ds.Range(ds.Cells(buf, "A"), ds.Cells(ds.Cells(ds.Rows.Count, 37).End(xlUp).Row, "A")).Value = file ↓ ThisWorkbook.Sheets("Sheet2")のA列、[buf]行目〜同シートのA列、 ThisWorkbook.Sheets("Sheet2")のAK1048576セルから上に見ていき最初にデータが入っている行の行番号の行 まで、【file】という変数の中身を書き込みなさい ====================================================== .Parent.Close False ↓ Workbooks.Open(desktop & file).Sheets("Sheet1")の親(つまり、開いたブック)を閉じなさい
という命令になっています。
■3
いずれも、既に述べたようにまずは【ステップ実行】して動きを確認したり、わからない命令はネット検索してみてください。
それでもわからなければ、「×××について□□□と解釈しましたが、△△△とすると☆☆☆となってしまいます。」など具体的に聞くと、アドバイスが得られると思います。
なお、【ステップ実行】という言葉を聞いたことがなければ↓を読んでみてください。
【ステップ実行】 https://www.239-programing.com/excel-vba/basic/basic023.html http://plus1excel.web.fc2.com/learning/l301/t405.html
【ブレークポイント】 https://www.239-programing.com/excel-vba/basic/basic022.html https://www.tipsfound.com/vba/01010
【イミディエイトウィンドウ】 https://www.239-programing.com/excel-vba/basic/basic024.html https://excel-ubara.com/excelvba1/EXCELVBA486.html
【ローカルウィンドウ】 https://excel-ubara.com/excelvba4/EXCEL266.html http://excelvba.pc-users.net/fol8/8_2.html
(もこな2) 2023/01/27(金) 12:18:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.