【マクロ】エクセルに指定した複数のシートを削除 数百以上あるエクセルファイルがある為、一括で指定した

【マクロ】エクセルに指定した複数のシートを削除

数百以上あるエクセルファイルがある為、一括で指定したシートを一括削除したいです。

【備考】
フルパスは取得済みです

質問者からの補足コメント

• 1)添付した写真のファイル名は適当です。
  本来のファイルは全てとは言いきれませんがそれに対応出来るシートは多くあります。
  
  2)Ｄ欄のシート全てを全てのブックに対して削除実行をしたいです。
  
  3)特定のフォルダ内にファイルがあるとゆうよりその中にサブフォルダが大量ににあるのでサブフォルダを含むフルパスとなっています。

    補足日時：2019/05/23 19:30

No.6 ベストアンサー 回答者： tom04 回答日時： 2019/05/29 20:42

No.2・5です。

＞wB.Save
の前に

＞wB.CheckCompatibility = False
の1行を追加したらどうなりますか？

※　未検証なので、ダメならごめんなさい。m(_ _)m

No.5 回答者： tom04 回答日時： 2019/05/25 00:28

No.2です。

前回は勘違いしていました。
各行ごとでファイルとシート名が1セットだと思っていました。
各ファイルごとで、D列のシート名すべてを対象にあればそのシートを削除したい！
というコトですね。

↓のコードにしてみてください。

Sub Sample2()
　Dim i As Long, j As Long, k As Long
　Dim sCnt As Long, cnt As Long
　Dim fN As String, sN As String
　Dim wB As Workbook, wS As Worksheet
　Dim myStr As String, myAry

　　With ThisWorkbook.Worksheets("Sheet1")
　　　sCnt = .Cells(Rows.Count, "D").End(xlUp).Row - 1
　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　fN = Dir(.Cells(i, "A"))
　　　　　　If fN <> "" Then
　　　　　　　Workbooks.Open .Cells(i, "A")
　　　　　　　Set wB = ActiveWorkbook
　　　　　　　　If wB.Worksheets.Count > 1 Then
　　　　　　　　　For k = 1 To wB.Worksheets.Count
　　　　　　　　　　Set wS = wB.Worksheets(k)
　　　　　　　　　　　For j = 2 To .Cells(Rows.Count, "D").End(xlUp).Row
　　　　　　　　　　　　sN = .Cells(j, "D")
　　　　　　　　　　　　　If wS.Name = sN Then
　　　　　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　　　　　If myStr = "" Then
　　　　　　　　　　　　　　　myStr = sN
　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　myStr = myStr & "," & sN
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　End If
　　　　　　　　　　　Next j
　　　　　　　　　Next k
　　　　　　　　　　If Len(myStr) > 0 Then
　　　　　　　　　　　myAry = Split(myStr, ",")
　　　　　　　　　　　Application.DisplayAlerts = False
　　　　　　　　　　　　For k = 0 To UBound(myAry)
　　　　　　　　　　　　　wB.Worksheets(myAry(k)).Delete
　　　　　　　　　　　　Next k
　　　　　　　　　　　Application.DisplayAlerts = True
　　　　　　　　　　End If
　　　　　　　　　Select Case cnt
　　　　　　　　　　Case sCnt
　　　　　　　　　　　.Cells(i, "B") = "全シート削除"
　　　　　　　　　　Case 0
　　　　　　　　　　　.Cells(i, "B") = "該当シートなし"
　　　　　　　　　　Case Else
　　　　　　　　　　　.Cells(i, "B") = cnt & "シート削除"
　　　　　　　　　End Select
　　　　　　　　Else
　　　　　　　　　.Cells(i, "B") = "シート数が1つのため削除不可"
　　　　　　　　End If
　　　　　　　　　fN = Dir()
　　　　　　　　　wB.Save
　　　　　　　　　wB.Close
　　　　　　　　　myStr = ""
　　　　　　Else
　　　　　　　.Cells(i, "B") = "該当ファイルなし"
　　　　　　End If
　　　　　　　cnt = 0
　　　　Next i
　　End With
　　　MsgBox "完了"
End Sub

※　余計なお世話かもしれませんが、
小さくて詳細はわかりませんけどA列のパスを拝見するともしかして同じフォルダにあるファイルに対しての処理になるのでしょうかね。

もしそうであればわざわざすべてのフルパスを書き出さなくてもできそうですが・・・m(_ _)m

この回答へのお礼

非常に助かりました！
ひとつだけ解決できない部分があります。シート削除後、エクセルが古いこともあり【互換チェック】が表示されます。保存する為、手動で続行クリックする手間がかかってしまうのですが解決出来ますでしょうか？

お礼日時：2019/05/29 09:27

No.4 回答者： tatsu99 回答日時： 2019/05/24 16:40

No3です。

補足ありがとうございました。
１つのファイルの中にSheetA,SheetB,SheetCがあるとします。
D列で指定されたシート名がSheetX,SheetY,SheetA,AheetB,SheetCの場合、順に削除をおこなうと以下のようになります。
SheetXは存在しない為、「①シートが見つかりませんでした」が設定させる
SheetYは存在しない為、「②シートが見つかりませんでした」が設定させる
SheetAは存在するので１件、削除完了
SheetBは存在するので１件、削除完了
よって「③２個削除完了」が設定される
SheetCは最後の１個なので、「④シートが1個の為、削除しませんでした」が設定される

上記のような場合、①～④のどのメッセージを設定すれば良いのでしょうか。

この添付された画像のシート名（削除対象のファイルとシート名を記述したシート）は何でしょうか。

No.3 回答者： tatsu99 回答日時： 2019/05/24 09:19

画像のC１に記述されている内容が読み取れません。

B列とC列は削除結果を設定するように見えますが、具体的には何を設定するのですか？

この回答へのお礼

B列にC1に書いてあることを設定するように記載しました。

記載内容
何個削除完了
シートが見つかりませんでした
シートが1個の為、削除しませんでした

お礼日時：2019/05/24 13:06

No.2 回答者： tom04 回答日時： 2019/05/23 21:55

こんばんは！

一例です。
お示しの画像はマクロ記載ブックの「Sheet1」だという前提です。

Sub Sample1()
　Dim i As Long, k As Long
　Dim fN As String, sN As String
　Dim wB As Workbook, wS As Worksheet
　Dim myFlg As Boolean
　
　With ThisWorkbook.Worksheets("Sheet1")
　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　fN = Dir(.Cells(i, "A"))
　　　sN = .Cells(i, "D")
　　　　If fN <> "" Then
　　　　　Workbooks.Open .Cells(i, "A")
　　　　　Set wB = ActiveWorkbook
　　　　　　For k = 1 To wB.Worksheets.Count
　　　　　　　Set wS = wB.Worksheets(k)
　　　　　　　　If wS.Name = sN Then
　　　　　　　　　myFlg = True
　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next k
　　　　　　　If myFlg = True Then
　　　　　　　　If wB.Worksheets.Count > 1 Then
　　　　　　　　　Application.DisplayAlerts = False
　　　　　　　　　　wB.Worksheets(sN).Delete
　　　　　　　　　Application.DisplayAlerts = True
　　　　　　　　　.Cells(i, "B") = "○"
　　　　　　　　Else
　　　　　　　　　.Cells(i, "B") = "シート数が1つのため削除不可"
　　　　　　　　End If
　　　　　　　　　myFlg = False
　　　　　　　Else
　　　　　　　　.Cells(i, "B") = "該当シートなし"
　　　　　　　End If
　　　　　　　　fN = Dir()
　　　　　　　　wB.Save
　　　　　　　　wB.Close
　　　　Else
　　　　　.Cells(i, "B") = "該当ファイルなし"
　　　　End If
　　Next i
　End With
　　MsgBox "完了"
End Sub

※　1ファイルずつ開いて操作していますので、そこそこ時間を要すると思います。

※　未検証なので、
お望み通りにならなかったらごめんなさい。m(_ _)m

この回答へのお礼

試した結果、削除できたりできなかったりです。

お礼日時：2019/05/24 12:57

No.1 回答者： rukaandkaito 回答日時： 2019/05/23 15:23

全てのファイル名と、それに対応するシートが記載されているのでしょうか

Public Sub psDelSht()
Dim intR As Integer
intR = 2
Do Until Sheets("操作用シート").Cells(1, intR).Value = ""
Workbooks.Open Filename:=Sheets("操作用シート").Cells(intR, 1).Value
ActiveWorkbook.Sheets(Sheets("操作用シート").Cells(intR, 4).Value).Delete
ActiveWorkbook.Close True
intR = intR + 1
Loop

End Sub

もしＤ欄のシート全てを全てのブックに対して行うのであれば上記Ｄｏ文の中でＤ列のデータ分ループが必要です

また、特定のフォルダ内の全てのブックが対象ということであれば
For Eachでループさせて対応出来ます

この回答へのお礼

Ｄ欄のシート全てを全てのブックに対して実行したいです。
また、指定フォルダ内のサブフォルダにファイルがあるのでサブフォルダ含むフルパスになります。

お礼日時：2019/05/24 13:00