PDFの分割と保存（横向きでスキャンしてしまったPDFを縦に修正）自分用メモ

タグ　VBA Excel


PDFを分割するソフトが入れられない場合VBAで分割して、フォルダ分けもしてファイル名も指定の名前で保存するというコードです。

 

マクロのファイルでは２つシートがあります。

 

●進捗状況シート

保存する場所の記載やB列の名前を.docxに変更しておいてください。
![1.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/d94617d3-b209-173f-e507-4ad279adc0df.png)



 

●集計シート

マクロで作成されるのでマクロ実行前は真っ白な状態
![2.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/3fd1536b-18de-198a-3ee9-b39f810d084f.png)



 
マクロを実行する前に２つ設定があります。


①参照設定でWordにチェック👆
![3.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/b7e9e6da-0478-c79b-0cb3-457e0645e558.png)

 

②PDFがあるフォルダでコマンド操作をする。

’注意！

あらかじめフォルダのバックアップをしてから実行しないと、元のpdfファイルがなくなってしまう。

階層のファイルの拡張子を変更
for %d in (*.pdf) do (  　　　　　
    ren "%d"  *.docx
)

 

コマンド後のフォルダの状態
![4.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/47f23014-9dde-0843-c6ac-4ac875ec69e0.png)

万が一、ファイルが破損して開けない場合は、wordを起動して、ファイル→開く→対象のファイルを参照→修復して開く
![ファイル修復.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/0e4d4fa0-30c4-a282-82aa-fb6db6b16d62.png)


これでPDFがWordで開けるようになりました。

wordで開いて、レイアウトがずれるときは、こちら↓の設定
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/ecea4328-18d1-129d-9906-db93a542dac3.png)
https://www.wordvbalab.com/word/2570/

スキャンの状態によってはOCR化されたけど、文字化けしている場合は↓の設定をしてみてください。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/ef12d5e5-9b3b-55a3-f2b4-a017c591e737.png)
https://helpx.adobe.com/jp/acrobat/using/edit-scanned-pdfs.html
 

マクロを実行すると下のような状態になる予定です。

１まい１枚縦向きで保存される。
![5.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/1927659/630ba95e-f713-5980-3818-99964e5ac25f.png)



 

 

 

 

③マクロ実行

～大まかな流れ～

集計シートのクリア
対象の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

'''