[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『特定のシートを削除し、マクロブックをxlsxで保存したい』(たくぼく)
あるフォルダ配下にあるファイル(xlsm)の特定のワークシート(シート名A、シート名B)のみを削除して、さらにファイルをxlsxの拡張子に変更した状態で保存させたいです。
ファイルは数十程度あり、それぞれ違うネームで同一フォルダに入っています。
よろしくお願いいたします。
< 使用 Excel:Microsoft365、使用 OS:Windows11 >
こんな感じで行けると思うけど、すでにファイルがある場合、上書き保存できない。 Option Explicit Const strDelSheetA As String = "Sheet1" Const strDelSheetB As String = "Sheet2" Const myPath As String = "C:\test\" Sub テスト() Dim files() As String Dim f As Variant Dim wb As Workbook Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject") files = GetFiles(myPath, "xls*") If (Not Not files) = 0 Then Exit Sub For Each f In files Set wb = Workbooks.Open(f, False, True) Application.DisplayAlerts = False On Error Resume Next wb.Sheets(strDelSheetA).Delete wb.Sheets(strDelSheetB).Delete wb.SaveAs wb.Path & "\" & fso.getBaseName(wb.FullName) & ".xlsx", xlWorkbookDefault On Error GoTo 0 wb.Close False Application.DisplayAlerts = True 'Kill wb.FullName Next f MsgBox "完了しました" End Sub Function GetFiles(pt As String, ext As String) As String() Dim cnt As Long Dim f As String Dim files() As String cnt = -1 f = Dir(pt & "*" & ext) Do Until f = "" cnt = cnt + 1 ReDim Preserve files(cnt) files(cnt) = pt & f f = Dir() Loop GetFiles = files End Function
(稲葉) 2023/05/02(火) 11:11:00
■1
>よろしくお願いいたします。
これは"質問"でしょうか?
質問であるなら現状のコードを示したうえで、以下を踏まえて具体的にどこで詰まっているか説明できないでしょうか?
1)エラーが発生する場合 「発生個所・エラー番号・エラーメッセージなど」の提示
2)エラーは発生しないが思った通りにならない場合 ××になるはずが○○になるのような説明
質問でなく作成依頼をしたいということならば、その旨明示しておいた方がお互いの気持ちがすれ違わなくてよいと思います。
■2
作成依頼ではないが、アプローチの着想がないのでそこを"質問"したいということならば
1. [あるフォルダ配下]を巡回して[あるファイル(xlsm)]だったら開く 2. ↑のブックのうち[特定のワークシート(シート名A、シート名B)]以外を新規ブックへコピーする 3. ↑を名前を付けて【xlsx形式】で保存する 4. ↑を閉じる 5. 2〜4を繰り返し
というアプローチで考えてみてはどうでしょうか?
(もこな2 ) 2023/05/02(火) 11:25:03
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.