『複数ブックを一つに集約、特定のシートが無い場合はブックを閉じる』（たんぽぽ）
初心者です。
とあるHPを参考にして、フォルダ内にある複数のブックを開き
特定のシートだけを集めて別のブックとして保存するマクロを作りました。
しかし、ブック内に特定のシートが無いとそこでストップしてしまいます。
やりたい事：
フォルダ内のブックを開いて特定のシート「商品」が無い場合はブックを閉じて
次のブックの処理にかかる
Do〜Loop の中にIF構文を作ってみようと試しましたがぜんぜん上手くいきません。
どなたかご教示いただけますと大変助かります。
Sub ブック集約()
Dim sFileName As String
Dim sWB As Workbook
Dim dWB As Workbook
Dim dSheetCount As Long
Dim WORK_FOLDER As String
Dim OUTPUT_FILE As String
Dim s, i As Long
WORK_FOLDER = Range("C2").Value '※末尾に"\"をつける
OUTPUT_FILE = Range("C3").Value
Application.ScreenUpdating = False
sFileName = Dir(WORK_FOLDER & "*.xls?")
If sFileName = "" Then Exit Sub
Set dWB = Workbooks.Add
dSheetCount = dWB.Worksheets.Count
Application.DisplayAlerts = False
s = 0
Do
Set sWB = Workbooks.Open(Filename:=WORK_FOLDER & sFileName)
Sheets("商品").Select
Range("D5:G14").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
sWB.Worksheets("商品").Copy After:=dWB.Worksheets(dSheetCount + s)
ActiveSheet.Name = s
s = s + 1
sWB.Close
sFileName = Dir()
Loop While sFileName <> ""
For i = dSheetCount To 1 Step -1
dWB.Worksheets(i).Delete
Next i
dWB.SaveAs Filename:=OUTPUT_FILE
dWB.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = False
MsgBox "集約処理が完了しました"
End Sub
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
隠居Zさま お返事ありがとうございます。
恥ずかしながら言葉の説明だけでは理解が出来ないくらいの初心者です。
コードを書いて正解を教えていただけると大変助かります。m(_ _)m
（たんぽぽ） 2025/02/21(金) 21:35:46
■１
＞Do〜Loop の中にIF構文を作ってみようと試しましたがぜんぜん上手くいきません。
どのようにうまくいきませんでしたか？（発想の方向性としては間違っていないと思います。）
■２
VBAの世界では基本的にシートやセル（オブジェクトと言います）は、きちんと明示すればいちいちアクティブにしたり選択したりする必要はありません。
また、【標準モジュール】でシートの指定を省略すると、ActiveSheetを指定したものとみなされるルールです。
何らかの拘りがあれば別ですが、そうでないならば可読性向上の観点からもActive○○に依存しない記述にすることをお勧めします。
■３
上記で軽く【オブジェクト】に触れましたが、VBAにはオブジェクトを格納する変数が用意されています。
たとえばシートはWorksheetオブジェクトなどに格納できます。
こいつをうまく使ってやることでも、シートの有無を判定することができます。
■４
細かい話ですが↓のうち「s」はValiant型になります。
Dim s, i As Long
せっかく指定するのであれば、↓のように記述することをお勧めします。
Dim s As Long, i As Long
■５
ということなどを踏まえ、提示のコードを私なりに整理しつつ修正してみると↓のような感じになります。
Sub 整理()
Dim MySH As Worksheet
Dim sFileName As String
Dim sWB As Workbook, dWB As Workbook
Dim WORK_FOLDER As String, OUTPUT_FILE As String
With ActiveSheet
WORK_FOLDER = .Range("C2").Value '※末尾に"\"をつける
OUTPUT_FILE = .Range("C3").Value
End With
Stop 'ブレークポイントの代わり
sFileName = Dir(WORK_FOLDER & "*.xls?")
Do Until sFileName = ""
With Workbooks.Open(Filename:=WORK_FOLDER & sFileName)
'==================================================================
Set MySH = Nothing
On Error Resume Next
Set MySH = .Worksheets("商品") '←セットしてみる
On Error GoTo 0
If Not MySH Is Nothing Then 'セットが成功していてNothingじゃなかったら、商品というシートがあるということ
Stop 'ブレークポイントの代わり
If dWB Is Nothing Then
MySH.Copy
Set dWB = Workbooks(Workbooks.Count)
Else
MySH.Copy After:=dWB.Worksheets(dWB.Worksheets.Count)
End If
dWB.Worksheets(dWB.Worksheets.Count).Name = dWB.Worksheets.Count - 1
End If
'==================================================================
.Close False
End With
sFileName = Dir()
Loop
Stop 'ブレークポイントの代わり
dWB.SaveAs Filename:=OUTPUT_FILE
dWB.Close
MsgBox "集約処理が完了しました"
End Sub
※コンパイルエラーにならないことしかチェックしてないのでミスっていたらごめんなさい。
※完成品のプレゼントを意図したものではなく研究材料として提供しています。 採用される場合は、ステップ実行等により研究の上、理解できてから必要な部分のみご自身のコードに組み込んでください。
（もこな２ ） 2025/02/21(金) 21:37:54
■６
＞初心者の私には理解できませんでした。
冒頭のコードを"作った"なら、落ち着いてステップ実行すれば理解できると思います。 余力ができたときにでも研究してみてください。
ステップ実行という言葉がわからないとか、どうやって研究したらよいかわからないということであれば、↓あたりを読んでみてはどうでしょうか？
【ステップ実行】 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
■７
＞ご提案いただいたコードもどこをどう使えば良いのか
繰り返しになりますが、研究材料として提供しました。 使えという意味ではありませんので、仕組みなどの研究に興味がなければご放念ください。
一応、以下のような考えで冒頭のコードを整理しただけなので、結果は同じになるはずです。
・「■２」で述べたように冗長と思われる部分を修正
・「■３」で述べた方法でシートの有無を判定
・新規ブックを作って、後から初期シートを削除しているのが無駄だとおもったので、 目的のシートをコピーして、直接新規ブックを作成するように修正
・シート名用のカウンタは、シートの枚数を数えれば事足りるので廃止
(と書いていて、値貼付けまで削ってしまっていたのに気づきましたので修正提示します)
Sub 整理_修正()
Dim MySH As Worksheet
Dim sFileName As String
Dim sWB As Workbook, dWB As Workbook
Dim WORK_FOLDER As String, OUTPUT_FILE As String
With ActiveSheet
WORK_FOLDER = .Range("C2").Value '※末尾に"\"をつける
OUTPUT_FILE = .Range("C3").Value
End With
Stop 'ブレークポイントの代わり
sFileName = Dir(WORK_FOLDER & "*.xls?")
Do Until sFileName = ""
With Workbooks.Open(Filename:=WORK_FOLDER & sFileName)
'==================================================================
Set MySH = Nothing
On Error Resume Next
Set MySH = .Worksheets("商品") '←セットしてみる
On Error GoTo 0
If Not MySH Is Nothing Then 'セットが成功していてNothingじゃなかったら、商品というシートがあるということ
Stop 'ブレークポイントの代わり
If dWB Is Nothing Then
MySH.Copy
Set dWB = Workbooks(Workbooks.Count)
Else
MySH.Copy After:=dWB.Worksheets(dWB.Worksheets.Count)
End If
With dWB.Worksheets(dWB.Worksheets.Count)
.Range("D5:G14").Copy
.Range("D5:G14").PasteSpecial Paste:=xlPasteValues
.Name = dWB.Worksheets.Count - 1
End With
End If
'==================================================================
.Close False
End With
sFileName = Dir()
Loop
Stop 'ブレークポイントの代わり
dWB.SaveAs Filename:=OUTPUT_FILE
dWB.Close
MsgBox "集約処理が完了しました"
End Sub
■８
残念ながら「■１」のお返事がないですが、方向性は間違ってないです。
「■３」のような判定でもよいですし、隠居Zさんがアドバイスされているように、ループ処理でシートの名前を見ていき"商品"という名前のシートがあった時だけ処理するといったことでもよいと思います。
Sub 説明用()
Dim sWB As Workbook
Dim MySH As Worksheet
Set sWB = Workbooks.Open(Filename:="c:\hogehoge\hoge.xlsx")
For Each MySH In sWB.Worksheets
If MySH.Name = "商品" Then
MsgBox "シートコピーとか値貼り付けとかする"
End If
Next MySH
End Sub
（もこな２） 2025/02/22(土) 01:37:00
「■７」で作っていただいたコード「整理_修正」は思ったとおりの動きをスムーズにしてくれました。
本当にありがとうございました！
すでにお察しかと思いますが冒頭のコードは「作った」というよりあるHPに掲載されていたコードをコピーして自分のしたい事を付け足しただけのものです。
見栄ではなくうっかり「作った」と書いてしまいましたが後から読み返すと自分のVBAの知識が今よりずっと高いように思われても仕方ない文章だったと反省しています。
なので、ステップ実行で研究する方法も言われて初めて知りました、これからちゃんと学びたいと思います。
お返事うまく出来ませんでしたが「■８」の隠居Zさんもアドバイスしてくれた方法にもまたチャレンジしたいと思います。
本当にいろいろとご親切に教えてくださりありがとうございました！
（たんぽぽ） 2025/02/22(土) 11:01:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.