Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
83 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【82054】PDF　連番保存 はる 22/8/29(月) 17:29 発言[未読]
【82055】Re:PDF　連番保存 OK 22/8/30(火) 8:48 発言[未読]
【82056】Re:PDF　連番保存 OK 22/8/30(火) 8:53 発言[未読]
【82058】Re:PDF　連番保存 はる 22/8/30(火) 17:34 発言[未読]
【82059】Re:PDF　連番保存 OK 22/8/30(火) 18:03 発言[未読]
【82060】Re:PDF　連番保存 OK 22/8/30(火) 18:10 発言[未読]
【82061】Re:PDF　連番保存 OK 22/8/31(水) 8:58 発言[未読]
【82062】Re:PDF　連番保存 はる 22/8/31(水) 9:38 発言[未読]
【82063】Re:PDF　連番保存 OK 22/8/31(水) 11:58 発言[未読]
【82054】PDF　連番保存
発言  はる  - 22/8/29(月) 17:29 -
引用なし
パスワード
   PDF保存をする際に、同じフォルダ名があると上書き保存されてしまいます。
同じファイルがある場合、〜(1).pdfと、連番で保存していきたいです。

デスクトップに保存までのVBAは書けましたが、連番がどうにもうまくいきません。

ご助言いただけますでしょうか。


'名前をつけて保存
　　Dim Desktop_Path As String
　　Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
　　With ActiveSheet
　　　　.ExportAsFixedFormat _
　　　　Type:=xlTypePDF, _
　　　　Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
　　End With

　　Application.DisplayAlerts = True
【82055】Re:PDF　連番保存
発言  OK  - 22/8/30(火) 8:48 -
引用なし
パスワード
   Dir関数の戻り値でファイルの有無の判定ができます。
ファイルパスが既に存在する場合はDo ~ Loopを使って
カウントアップして(1),(2)をファイル名に付加してファイル
パスが存在しなくなるまでループしてファイル名を生成
するようにしてはいかがでしょう？
【82056】Re:PDF　連番保存
発言  OK  - 22/8/30(火) 8:53 -
引用なし
パスワード
   参考HPです。

ht　tps://qiita.com/yagi_eng/items/cc7570b3878818a8e495
【82058】Re:PDF　連番保存
発言  はる  - 22/8/30(火) 17:34 -
引用なし
パスワード
   ありがとうございます。参考に作成してみましたが、上書き保存されてしまいます。
初心者で分からないことだらけで申し訳ございません…。


名前をつけて保存
Dim Desktop_Path As String
Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
End With
'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
'''ファイル名の末尾に(i)をつける
If Dir(fileSaveName) <> "" Then
'保存ファイル名を取得
fileSaveName_name = Dir(fileSaveName)
'保存先のフォルダを取得
fileSaveName_path = Replace(fileSaveName, fileSaveName_name, "")

'保存ファイル名の末尾に(i)をつける
k = 1
Do While Dir(fileSaveName) <> ""
fileSaveName = fileSaveName_path & Replace(fileSaveName_name, ".pdf", "") & "(" & k & ")" & ".pdf"
k = k + 1
Loop
End If
【82059】Re:PDF　連番保存
発言  OK  - 22/8/30(火) 18:03 -
引用なし
パスワード
   PDF作成した後にファイル名を生成しても意味がない
ですよ。
コードをよく見ましょう。
【82060】Re:PDF　連番保存
発言  OK  - 22/8/30(火) 18:10 -
引用なし
パスワード
   考え方です。

PDFのファイルパスを生成する
↓
生成したファイルパスが存在したら存在しなくなるまでループ
する。
↓
PDFを生成したファイルパスで保存する。
【82061】Re:PDF　連番保存
発言  OK  - 22/8/31(水) 8:58 -
引用なし
パスワード
   はるさんの22/8/30(火) 17:34のコードにコメントを付加してみました。

Dim Desktop_Path As String
'****デスクトップのパス取得
Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
'****アクティブシートをPDFファイルとして保存(デスクトップにA1セルに入力されている名前を付けて保存)
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
End With

'****↓PDFファイルは作成済みなのでその後にファイル名を生成しても無意味。
’またfileSaveNameは変数宣言されてないし、fileSaveNameに何も格納されてないので
'Dir(fileSaveName) の戻り値は必ず""となるので、このIf文はスルーされる
'*****

'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
'''ファイル名の末尾に(i)をつける
If Dir(fileSaveName) <> "" Then
'保存ファイル名を取得
fileSaveName_name = Dir(fileSaveName)
'保存先のフォルダを取得
fileSaveName_path = Replace(fileSaveName, fileSaveName_name, "")

'保存ファイル名の末尾に(i)をつける
k = 1
Do While Dir(fileSaveName) <> ""
fileSaveName = fileSaveName_path & Replace(fileSaveName_name, ".pdf", "") & "(" & k & ")" & ".pdf"
k = k + 1
Loop
End If
【82062】Re:PDF　連番保存
発言  はる  - 22/8/31(水) 9:38 -
引用なし
パスワード
   詳細にありがとうございます。
流れを見て修正し、PDF保存まではできたものの、やはり（１）…と追加するところで手詰まりになってしまいます。

Dim k As Integer　が抜けていたことが原因かと思ったのですが見当違いでしょうか…。


Dim Desktop_Path As String
Dim k As Integer
'****デスクトップのパス取得
Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")


'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
'''ファイル名の末尾に(i)をつける
If Dir(Desktop_Path) <> "" Then
'保存ファイル名を取得
fileSaveName_name = Dir(Desktop_Path)
'保存先のフォルダを取得
Desktop_Path_path = Replace(fileSaveName, Desktop_Path_name, "")

'保存ファイル名の末尾に(i)をつける
k = 1
Do While Dir(Desktop_Path) <> ""
fileSaveName = Desktop_Path_path & Replace(Desktop_Path_name, ".pdf", "") & "(" & k & ")" & ".pdf"
k = k + 1
Loop
End If
'****アクティブシートをPDFファイルとして保存(デスクトップにA1セルに入力されている名前を付けて保存)
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Desktop_Path & "\" & "" & .Range("AI1").Value & ".pdf"
End With
【82063】Re:PDF　連番保存
発言  OK  - 22/8/31(水) 11:58 -
引用なし
パスワード
   なるべく元コードを生かすようにして書き換えました。

Sub test()
'名前をつけて保存
Dim Desktop_Path As String
Dim fileSaveName As String
Dim fileSaveName_Name As String
Dim fileSavePath As String
Dim kaku As String
Dim ws As Worksheet

　Set ws = ActiveSheet
　kaku = "pdf"
　Desktop_Path = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
　fileSaveName = ws.Range("AI1").Value
　fileSaveName_Name = fileSaveName
　fileSavePath = Desktop_Path & "\" & fileSaveName_Name & "." & kaku
　'''保存しようとしたファイル名と既に同じファイル名が存在するならば、
　'''ファイル名の末尾に(i)をつける
　If Dir(fileSavePath) <> "" Then
　　 k = 0
　　Do While Dir(fileSavePath) <> ""
　　　k = k + 1
　　　'保存ファイル名を取得
　　 fileSaveName_Name = fileSaveName & Format(k, "(0)")
　　 fileSavePath = Desktop_Path & "\" & fileSaveName_Name & "." & kaku
　　Loop
　End If
　ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileSavePath
　Set ws = Nothing
End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
83 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free