質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

2666閲覧

VBA 複数のブックから複数のシートをまとめたい

退会済みユーザー

退会済みユーザー

総合スコア0

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2021/05/17 04:21

編集2021/06/08 08:30

前提・実現したいこと

VBAで複数のブックから複数のシートを一つのブックにまとめたい。

発生している問題・エラーメッセージ

ブックによってとりだしたいシートが1つの時と2つの時があるのですが2つめがあった場合は2つめもまとめてなかった場合はスルーしたいのですがスルーができません。
また、シート名をブック名にしたいのですが2つめがあった場合は[ブック名.2]としたいのですがその指定もできません。
エラーメッセージ

該当のソースコード

VBA ソースコード Sub Sample() Dim sFile As String Dim sWB As Workbook, dWB As Workbook Dim dSheetCount As Long Dim i As Long Const SOURCE_DIR As String = "フォルダ" Const DEST_FILE As String = "ブック" Application.ScreenUpdating = False '指定したフォルダ内にあるブックのファイル名を取得 sFile = Dir(SOURCE_DIR & "*.xls") 'フォルダ内にブックがなければ終了 If sFile = "" Then Exit Sub '集約用ブックを作成 Set dWB = Workbooks.Add '集約用ブック作成時のシート数を dSheetCount = dWB.Worksheets.Count Do 'コピー元のブックを開く Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile) 'コピー元の「a,a(2)←あれば」シートを集約用ブックにコピー sWB.Worksheets(Array("a", "a(2)")).Copy After:=dWB.Worksheets(dSheetCount) 'シート名をフォルダ名、a(2)がある場合はフォルダ名.2 ActiveSheet.Name = sFile 'コピー元ファイルを閉じる sWB.Close '次のブックのファイル名を取得 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 Application.ScreenUpdating = False End Sub ### 試したこと ここに問題に対して試したことを記載してください。 ふくすう ### 補足情報(FW/ツールのバージョンなど) ここにより詳細な情報を記載してください。

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

sazi

2021/05/17 05:04

要件は前質問の方が良くまとまっていましたよ。
guest

回答1

0

ベストアンサー

VBA

1Dim ws As Worksheet 2For Each ws In sWB.Worksheets 3 If ws.Name = "a" Then 4 ws.Copy After:=dWB.Worksheets(dWB.Worksheets.Count) 5 ActiveSheet.Name = sFile 6 ElseIf ws.Name = "a(2)" Then 7 ws.Copy After:=dWB.Worksheets(dWB.Worksheets.Count) 8 ActiveSheet.Name = sFile & ".2" 9 End If 10Next 11

投稿2021/05/17 05:29

jinoji

総合スコア4585

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

退会済みユーザー

退会済みユーザー

2021/05/17 09:05

jinoji様 回答ありがとうごうございます。 無事動きました、できれば拡張子を消したく 試行錯誤していましたがうまくいきませんのでもしよろしければ教えてください。
jinoji

2021/05/17 09:12

たとえば Left(sFile, InStrRev(sFile, ".") - 1) とかでできると思います。
退会済みユーザー

退会済みユーザー

2021/05/17 09:20

構文エラーがでてしまします。 こちらだとa.2の場合に.2も消えてしましませんか?
jinoji

2021/05/17 09:31

.2をつける前の sFile の部分を、上記の記述に差し替えるという意味で書きました。 あるいは、以下のようにしたらわかりやすいですか。 Dim sFileBaseName sFileBaseName = Left(sFile, InStrRev(sFile, ".") - 1) Dim ws As Worksheet For Each ws In sWB.Worksheets If ws.Name = "a" Then ws.Copy After:=dWB.Worksheets(dWB.Worksheets.Count) ActiveSheet.Name = sFileBaseName ElseIf ws.Name = "a(2)" Then ws.Copy After:=dWB.Worksheets(dWB.Worksheets.Count) ActiveSheet.Name = sFileBaseName & ".2" End If Next
退会済みユーザー

退会済みユーザー

2021/05/17 09:53

お手数お掛けしますが sFileBaseName = Left(sFile, InStrRev(sFile, ".") - 1) この文でコンパイルエラーがでてしまいます。
退会済みユーザー

退会済みユーザー

2021/05/17 09:59

無事動きました、ありがとうございました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問