[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『同一フォルダ下にある複数エクセルファイルを1ファイルにしたい』（あらじぃ）
同一フォルダ下にある複数エクセルファイルを、1ファイル複数シートに集約したい。その際、各ファイルのファイル名を各シート名に転記したい。
上記の要望をもとに、人に作ってもらったVBAのマクロ(?)が下記なのですが、
これだと
1)各シート名が"ファイル名+元のシート名"になってしまう
2)シート名が左から昇順にならない
という動きになってしまいます。
もともと作業フォルダに入っているファイル郡は、すべて数字で連番のファイルです。(例：123.xls , 124.xls, 125.xls)
よって、出来上がりのシート名は上記の例だと左から123,124,125という順番での出力を希望します。どこをどう修正すればよいでしょうか。
(すいません、マクロ素人でして..)
Sub book_sum()
Dim sFile As String
Dim sWB As Workbook, dWB As Workbook
Dim dSheetCount As Long
Dim i As Long
Dim dl_Dir As String
Dim SOURCE_DIR As String
Dim DEST_FILE As String
Application.ScreenUpdating = False '更新非表示
Cells(2, 4).ClearContents
'ダイアログでフォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "保存フォルダを選択して下さい"
If .Show = False Then Exit Sub
dl_Dir = .SelectedItems(1)
End With
SOURCE_DIR = dl_Dir & "\"
DEST_FILE = SOURCE_DIR & "AllReports.xlsx"
'指定したフォルダ内にあるブックのファイル取得
sFile = Dir(SOURCE_DIR & "*.xls*")
'フォルダ内にブックがなければ終了
If sFile = "" Then Exit Sub
'集約用ブックを作成
Set dWB = Workbooks.Add
ActiveSheet.Name = "st_book_sum"
'集約用ブック作成時のシート数を取得
dSheetCount = dWB.Worksheets.Count
Do
'AllReports.xlsxのチェック
If sFile <> "AllReports.xlsx" Then
Set sWB = Workbooks.Open(FileName:=SOURCE_DIR & sFile, ReadOnly:=True)
For i = 1 To Sheets.Count
Sheets(i).Visible = True
'シートを集約用ブックにコピー
sWB.Worksheets(i).Copy After:=dWB.Worksheets(dSheetCount)
'シート名を変更
ActiveSheet.Name = Left(sFile, InStrRev(sFile, ".") - 1) & ActiveSheet.Name
Next i
'コピー元ファイルを閉じる
sWB.Close SaveChanges:=False
End If
'次のブックのファイル名を取得
sFile = Dir()
Loop While sFile <> ""
'集約用ブック作成時にあったシートを削除
Application.DisplayAlerts = False
For i = dSheetCount To 1 Step -1
dWB.Worksheets(i).Delete
Next i
Application.DisplayAlerts = True
'集約用ブックを保存して閉じる
dWB.SaveAs FileName:=DEST_FILE
dWB.Close SaveChanges:=False
ThisWorkbook.Sheets(1).Cells(2, 4) = dl_Dir
MsgBox "完了しました" & vbCrLf & "作業フォルダにファイルが作成されました"
Application.ScreenUpdating = True '更新表示
End Sub
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
作ってもらったって、その人に聞いたほうがいいんじゃ。 もし職業として作ってもらったものなら、コード載せるのもどうなの？って気はしますが・・・。
＞ ActiveSheet.Name = Left(sFile, InStrRev(sFile, ".") - 1) & ActiveSheet.Name この部分書き換えればいけるはずなので、まず自分で頑張ってみては。
https://excel-ubara.com/excelvba1/EXCELVBA490.html
（稲葉） 2023/04/25(火) 22:01:28
一つずつ分解してデバッグすればわかると思うよ 聞くより手を動かした方が覚えるし早いよ
sWB.Worksheets(i).Copy After:=dWB.Worksheets(dSheetCount) シートの順番はここである程度決められるけど、dir関数の取得順に左右されるから確実じゃない あと、必ず3桁数字ならいいけど8,9,10なら、10,8,9の並びになる その場合、ファイル名を数として並べ替える必要があるからひと手間必要
作ってくれたひとに聞いた方がいいんじゃない？ 仕様変える時にもとのコードと変わってるとやりにくいし、いい気がしないと思うよ （稲葉） 2023/04/26(水) 05:51:51
■１
＞(すいません、マクロ素人でして..)
とはいえそれなりに質問を重ねられているので、ある程度は理解できてますよね。
まずは【ステップ実行】してどの部分が想定通りにいってないか確認されてみてはどうですか？
■２
＞上記の例だと左から123,124,125という順番での出力を希望します。
ステップ実行してみればわかるとおもいますが、Dir関数ではその順番で取得されるでしょうが↓のせいで逆順に並びますよね。
dSheetCount = dWB.Worksheets.Count sWB.Worksheets(i).Copy After:=dWB.Worksheets(dSheetCount)
なので、私なら【毎回、末尾シートの次】に挿入するようにします。
※稲葉さんが指摘されているように桁数が違えばDir関数で取得した段階で順番通りになりませんが・・・・
■３
＞各シート名が"ファイル名+元のシート名"になってしまう
既に指摘がありますが、そりゃ↓になっているのだからそうなりますよね
ActiveSheet.Name = Left(sFile, InStrRev(sFile, ".") - 1) & ActiveSheet.Name
~~~~~~~~~~~~~~~~~~
作ってもらったものであろうが、一から自分で作ったものであろうが、【現在のメンテナンス担当】は貴方ですから、わからない命令等があるなら、ちゃんと調べておかないとダメだと思います。
■４
＞LeftをRightに変更でいけますか？
なぜそのように考えたかわかりませんが↓で何を求めているのかよ～～く考えて（確認して）みてはどうでしょうか？
sFile = Dir(SOURCE_DIR & "*.xls*") Left(sFile, InStrRev(sFile, ".") - 1)
（もこな２） 2023/04/26(水) 12:49:11
（もこな２） 2023/06/04(日) 11:50:07
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.