回答受付が終了しました

エクセルVBAのマクロの質問です。 おわかりになられる方いらっしゃましたら、お教えくださいませ・・・。

Visual Basic | Excel320閲覧xmlns="http://www.w3.org/2000/svg">100

回答(2件)

0

こんな感じです。参考にしてください。 ##設定条件##: ①kakou-maeフォルダを作成(各処理するファイル[xlsxファイル]が格納されているフォルダ)(既存のものでOK) ②kakou-atoフォルダ(「base.xlsm」と「base.pdf」を格納するフォルダ)(既存のものでOK) ③base.xlsmファイルは任意の場所(既存場所でOK) [VBA内コード書き換え] ④コードをbase.xlsmのModuleにコピペ ⑤Const maepath As String = "C:\Users\○\Desktop\○\kakou-mae\"(加工するファイルのフォルダ先を記述) ※コード内(書き換え)のところ ※kakou-maeフォルダ「"C:\Users\○\Desktop\○\kakou-mae\"」を書き換える ⑥Const atopath As String = "C:\Users\○\Desktop\○\kakou-ato\"(加工後に格納するフォルダを記述) ※コード内(書き換え)のところ ※kakou-atoフォルダ「"C:\Users\○\Desktop\○\kakou-ato\"」を書き換える ##処理内容##: ①base.xlsmを起動し、処理マクロを実行する ②maepathにある各ファイルの各シートをコピーしbase.xlsmに貼り込む ※base.xlsmの中にある重複する既存シート名は削除され、新たに各ファイルのシートをコピーして貼り込むようにしています。 ③処理したbase.xlsmを上書き保存、base.xlsmをkakou-atoフォルダに同じ名前で保存格納 ④処理したbase.xlsmをpdfに変換し、kakou-atoフォルダにbase.pdfとして保存格納 ※③④は、格納フォルダに同名の既存ファイル(xlsm.pdf)があると上書き警告が出され「はい」で上書き保存します。 ※仮称「base.xlsm」としましたが、別の名前でもその別の名前のファイル名で保管されます。 ⑤表示ファイルを閉じる 以下コード(長いです) Sub test() Dim wb1 As Workbook, wb2 As Workbook Dim FSO As Object, f As Object Dim i, j As Long, n As Long Dim cnt As Long, num As Long Const maepath As String = "C:\Users\○\Desktop\○\kakou-mae\" 'kakou-maeフォルダ指定(書き換え) Const atopath As String = "C:\Users\○\Desktop\○\kakou-ato\" 'kakou-maeフォルダ指定(書き換え) Application.ScreenUpdating = False Set FSO = CreateObject("Scripting.FileSystemObject") Set wb1 = ThisWorkbook ReDim ary1(0) wb1.Activate With wb1 For i = 1 To .Worksheets.Count .Worksheets(i).Select n = UBound(ary1) ReDim Preserve ary1(n + 1) ary1(n + 1) = .Worksheets(i).name Next i End With 'コピー処理 For Each f In FSO.GetFolder(maepath).Files Workbooks.Open maepath & f.name Set wb2 = Workbooks(f.name) wb2.Activate cnt = wb1.Sheets.Count ReDim ary2(0) wb2.Activate With wb2 For i = 1 To .Worksheets.Count .Worksheets(i).Select n = UBound(ary2) ReDim Preserve ary2(n + 1) ary2(n + 1) = .Worksheets(i).name Next i End With num = 0 For i = UBound(ary2) To 1 Step -1 For j = 1 To UBound(ary1) If ary2(i) = ary1(j) Then Application.DisplayAlerts = False wb1.Worksheets(ary2(i)).Delete Application.DisplayAlerts = True cnt = cnt - 1 Exit For Else num = num + 1 End If Next j num = 0 If num = UBound(ary1) Then num = 0 End If wb2.Activate wb2.Worksheets(ary2(i)).Select ActiveSheet.Copy _ after:=wb1.Worksheets(cnt) 'シートコピー/ペースト Next i wb2.Close Next wb1.Activate Application.DisplayAlerts = False ActiveWorkbook.Save '上書き保存 Application.DisplayAlerts = True ActiveWorkbook.SaveAs Filename:= _ atopath & "base.xlsm", FileFormat:= _ xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False 'kakou-atoにxlsm保存 ActiveWorkbook.ExportAsFixedFormat xlTypePDF, atopath & "base.pdf" 'kakou-atoにpdf保存 '終了 Set FSO = Nothing Application.ScreenUpdating = True Application.Quit End Sub

0

いくつか不明な点がありますが、これでどうでしょうか。 ちなみに、Cドライブ直下にユーザーのファイルを置くのはやめた方がいいので、 >"C:\base.xlsm" というファイルに貼り付けて は "C:\sample\base.xlsm" というファイルに貼り付けて と言う場合です。 実際のファイルに変える場合は >Set twb = Workbooks.Open("C:\sample\base.xlsm") 'ひな形Bookを開く を書き替えてください。 Sub sample() Dim sfolder As String Dim dfolder As String Dim twb As Workbook Dim file As String Dim wb As Workbook Dim base As String ' sfolder = "C:\kakou-mae\" '前フォルダ dfolder = "C:\kakou-ato\" '後フォルダ file = Dir(sfolder & "*.xls?") '前フォルダの最初のExcelファイル名 Do While file <> "" 'ファイル名がある間 Set wb = Workbooks.Open(sfolder & file) '前フォルダのファイルを開く Set twb = Workbooks.Open("C:\sample\base.xlsm") 'ひな形Bookを開く wb.Sheets.Copy After:=twb.Sheets(twb.Sheets.Count) '前Bookのすべてのシートをひな形Bookの最後のシートの最後(右)にコピー base = Left(file, InStrRev(file, ".")) '前ファイルの拡張子を除いたファイル名 ActiveWorkbook.ExportAsFixedFormat xlTypePDF, dfolder & base & "pdf" 'PDFで保存 twb.Close True, dfolder & base & "xlsm" 'xlsmで閉じる(保存) wb.Close False '前ファイルを保存しないで閉じる file = Dir '次のファイル名 Loop '繰り返す End Sub