タグ　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

'''