タグ VBA Excel
PDFを分割するソフトが入れられない場合VBAで分割して、フォルダ分けもしてファイル名も指定の名前で保存するというコードです。
マクロのファイルでは２つシートがあります。
●進捗状況シート
保存する場所の記載やB列の名前を.docxに変更しておいてください。
●集計シート
マクロで作成されるのでマクロ実行前は真っ白な状態
マクロを実行する前に２つ設定があります。
①参照設定でWordにチェック👆
②PDFがあるフォルダでコマンド操作をする。
’注意！
あらかじめフォルダのバックアップをしてから実行しないと、元のpdfファイルがなくなってしまう。
階層のファイルの拡張子を変更
for %d in (*.pdf) do (
ren "%d" *.docx
)
コマンド後のフォルダの状態
万が一、ファイルが破損して開けない場合は、wordを起動して、ファイル→開く→対象のファイルを参照→修復して開く
これでPDFがWordで開けるようになりました。
wordで開いて、レイアウトがずれるときは、こちら↓の設定
https://www.wordvbalab.com/word/2570/
スキャンの状態によってはOCR化されたけど、文字化けしている場合は↓の設定をしてみてください。
https://helpx.adobe.com/jp/acrobat/using/edit-scanned-pdfs.html
マクロを実行すると下のような状態になる予定です。
１まい１枚縦向きで保存される。
③マクロ実行
～大まかな流れ～
集計シートのクリア
対象のwordファイルを開く
印刷の向きを変更
pdfのページ数を取得
スキャンした枚数とpdfのページ数があっていれば分割
名前を付けてPDF保存
コード
'''
Sub 分割保存処理●()
Set List = Workbooks("PDF分割0818.xlsm").Worksheets("進捗状況")
Set 集計シート = Workbooks("PDF分割0818.xlsm").Worksheets("集計シート")
'注意！！ファイルなし。資格なし以外で絞り込んでコピーして、マクロを実行させる。
'＝＝＝＝＝＝＝＝＝＝集計シートのクリア＝＝＝＝＝＝＝＝＝＝
集計シート.Activate
With 集計シート
Columns("A:D").Select
Selection.ClearContents
Selection.ClearFormats
End With
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
List.Activate
Dim LastRow As Integer '進捗状況の最終行
LastRow = List.Cells(Rows.count, 2).End(xlUp).Row
Debug.Print "最終行は、" & LastRow
'＊--------------＊--------------＊----＊集計＊---＊--------------＊--------------＊--------------＊
With List
.Columns("B:B").Select
Selection.Copy
End With
Dim LastRowC As Integer 'C列（重複なしの局名）＊最終行
Dim R As Range 'COUNTIFの出力セル
'集計前にシートを全てクリアにしないと失敗する
集計シート.Activate
With 集計シート
'A列に貼り付け
.Columns("A:A").PasteSpecial
Application.CutCopyMode = False
'B列に重複削除から１列空けてC1を２回書かないとエラーになる。
.Columns("A:A").Select
Selection.Copy
.Columns("C:C").PasteSpecial
Application.CutCopyMode = False
'重複データを取得したいセルを指定
.Range("C5").CurrentRegion.RemoveDuplicates 1, xlYes
'C列（重複なしの局名）＊最終行を取得
LastRowC = Cells(Rows.count, 3).End(xlUp).Row
'=================================
'D列にPDF名の個数を出力
For Each R In .Range("D5:D" & LastRowC)
R.Value = "=COUNTIF(A:A,C:C)"
Next
'値で貼り付け
.Columns("D:D").Select
Selection.Copy
.Columns("D:D").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'=================================
'=================================
'B列
Dim v As Integer
v = 0
For Each R In .Range("B7:B" & LastRow)
R.Value = "=VLOOKUP(A" & 7 + v & ",C:D,2,0)"
'=VLOOKUP(A5 + v & ",C:D,2,0)を下にコピーしていく書き方↑
v = v + 1
Next
'値で貼り付け
.Columns("B:B").Select
Selection.Copy
.Columns("B:B").PasteSpecial xlPasteValues
Application.CutCopyMode = False
'=================================
End With
'＊--------------＊--------------＊----＊'＊--------------＊--------------＊----＊'＊--------------＊--------------＊----＊
Dim i As Integer 'B5から繰り返し
Dim count As Integer 'ページ数とPDF名の個数
'============Wordを起動============='
Dim objWord As Word.Application
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Dim objDoc As Word.Document
'================================
'～～～~~~~◆～wordを開く～◆~~~~～～～～◆～'～~◆～
Dim openFolderName As String '開くフォルダ
Dim openFileName As String '開くファイル名
Dim OpenFilePath As String 'wordを開くパス
List.Activate
'開くフォルダ：C1に記載
openFolderName = List.Cells(1, 3).Value
Debug.Print "OpenFolderName →" & openFolderName
'wordからPDFに保存********
Dim saveFolderName As String '保存フォルダ
Dim saveFileName As String '保存ファイル名
Dim subFolderName As String 'E列の資格項目から取得
Dim saveFilePath As String '保存パス
'保存するフォルダ：C２に記載
saveFolderName = List.Cells(1, 3).Value
Debug.Print "saveFolderName →" & saveFolderName
'*******************************************************
'---------------------------------------------------------
'途中の行から行いたい場合は、５の部分をへんこうする
For i = 7 To LastRow
Debug.Print "処理するときの行（i）は、" & i
'注意！！拡張あり↓ B5が最初の行
openFileName = List.Cells(i, 2).Value
Debug.Print "OpenFileName →" & openFileName
OpenFilePath = openFolderName & "" & openFileName
Debug.Print "OpenFilePath →" & OpenFilePath
'ファイルを開く
Set objDoc = objWord.Documents.Open(OpenFilePath)
'～～～~~~~◆～'～～～~~~~◆～'～～～~~~~◆～'～~◆～
'印刷向き◇◆＝＝＝◆横向き→縦向き◇◆＝＝＝◆
Dim dc As Document
Set dc = objWord.Documents(1)
dc.PageSetup.Orientation = wdOrientPortrait
'◇◆＝＝＝◆◇◆＝＝＝◆◇◆＝＝＝◆◇◆＝＝＝◆
'◆全ページの画像の位置・回転の設定◆◆＝＝＝＝＝＝◆◆＝＝＝◆◆
Dim shp '型はいれなくてOK
Dim nWid As Integer '幅の値を保存
Dim nHei As Integer '高さの値を保存
'ここで倍率を設定します
Const C_W_PERCENT = 130 '貼付倍率を変更したい時に使用(幅)
Const C_H_PERCENT = 130 '貼付倍率を変更したい時に使用(高さ)
For Each shp In dc.Shapes
With shp
'前面
.WrapFormat.Type = wdWrapNone
'拡大縮小
nWid = .Width
nHei = .Height
.ScaleWidth (C_W_PERCENT / 100), True
.ScaleHeight (C_H_PERCENT / 100), True
'左右の余白内の収める
.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionMargin
'上下の余白内の収める
.RelativeVerticalPosition = _
wdRelativeVerticalPositionMargin
'画像を横向き→縦向き
.Rotation = -360
'中央寄せ
.Left = wdShapeCenter
'右寄せ
.Left = wdShapeCenter
End With
Next shp
'◆◆＝＝＝＝◆◆＝＝＝◆◆＝＝＝＝＝◆◆＝＝＝＝＝◆
'--- ワードファイルのページ数を取得 ---'
Dim Page As Integer
Dim b As Integer '集計シートのB列
Page = objDoc.Content.Information(wdNumberOfPagesInDocument)
Debug.Print "ページ枚数は、" & Page & "ページ"
'
' J列に取得したページ数の出力
List.Cells(i, 10).Value = Page
b = 集計シート.Cells(i, 2).Value
'---------------------------------------------------------------------
'進捗状況のJ列と集計シートのD列の値が一致しているか確認
If Page = b Then
'一致していればOKと出力
List.Cells(i, 11).Value = "OK"
'～～～～同じPDF分だけ出力～～～～
Dim j As Integer '開始ページ
j = 1
Debug.Print "j;" & j
' i （処理する行数）: 7でPage(枚数)：３のとき
' i + Page - 1：９行目まで処理するということ
Dim start As Integer
start = i
Dim endRow As Integer
endRow = i + Page - 1
'
For start = start To endRow
'開始ページ出力
List.Cells(start, 8).Value = j
'終了ページ出力
List.Cells(start, 9).Value = j
'保存ファイル名
saveFileName = List.Cells(start, 7).Value
Debug.Print "保存ファイル名" & saveFileName
'□□□□□□□□□□□□□□□□□□□□□□□□□□□
'保存サブフォルダ名を取得
subFolderName = List.Cells(start, 5).Value
Debug.Print "資格のフォルダ名" & subFolderName
'保存ファイルパス ＊同じ名前がある場合は上書きされる
saveFilePath = saveFolderName & "" & subFolderName & "" & saveFileName & ".pdf"
Debug.Print "saveFilePath →" & saveFilePath
'□□□□□□□□□□□□□□□□□□□□□□□□□□□
'PDFの分割・保存
objDoc.ExportAsFixedFormat OutputFileName:=saveFilePath, _
ExportFormat:=wdExportFormatPDF, _
Range:=wdExportFromTo, From:=List.Cells(start, 8).Value, To:=List.Cells(start, 9).Value
'作成済の場合：完了と出力
List.Cells(start, 12).Value = "完了"
'1行下がるごとにページ枚数加算
j = j + 1
Next start
'～～～～'～～～～'～～～～'～～～～
'次のPDFから処理するので、iに加算
i = endRow
'保存処理の型付け
objDoc.Close
Set objDoc = Nothing
Else
MsgBox "処理を中断します。ファイル枚数の確認をしてください。"
Exit For
End If
'---------------------------------------------------------------------
Next i
'Wordの片付け
objWord.Quit
Set objWord = Nothing
End Sub
'''