Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

740 / 76735

←次へ　｜　前へ→


	【81660】フォルダパスが変動しても対応したい。

のっち - 21/2/14(日) 22:12 -


	引用なし

	パスワード

行いたい事はデスクトップ上にあるとあるフォルダーの中にいくつかエクセルファイルがあります。(ファイル名が違うだけで同じ様な形)。

そのフォルダー内のファイルを全部開いて同じセルに決められた文字を入れた後、
それぞれPDFで出力して元のファイルを保存して閉じる。そしてそのフォルダーを開いておく、という形です。

フォルダ名〇は変動しない、★は変動する　AorBどちらかのフォルダ名がある。

Sub 指定フォルダーのExcelファイルを全て開く()

Dim myPath As String, myfile As String

If ThisWorkbook.Sheets(1).Range("B8") = "" Then
　MsgBox "数字の入力は必須です!"
　Exit Sub
End If

If Dir("〇〇〇★★★AAA)", vbDirectory) <> "" Then
　myPath = "〇〇〇★★★AAA)\"
ElseIf Dir("〇〇〇★★★BBB", vbDirectory) <> "" Then
　myPath = "〇〇〇★★★BBB)\"
Else
MsgBox "対象のファイルがありません。"
Exit Sub
End If
　
　myfile = Dir(myPath & "*.xlsx*")

　Do
　　Workbooks.Open Filename:=myPath & "\" & myfile
　　
　Dim i As Long
　For i = 1 To Sheets.Count
　　If Sheets(i).Visible = True Then
　　　Sheets(i).Range("H4") = ThisWorkbook.Sheets(1).Range("B8").Text
　
　 End If
　　
　Next i
　　myfile = Dir
　Loop Until myfile = ""　
Call pdfに出力
　
End Sub
---------------------------------------------------------------------
Sub pdfに出力()

Dim myPath As String, myfile As String

If Dir("〇〇〇★★★AAA)", vbDirectory) <> "" Then
　myPath = "〇〇〇★★★AAA)\"
ElseIf Dir("〇〇〇★★★BBB", vbDirectory) <> "" Then
　myPath = "〇〇〇★★★BBB)\"
Else
MsgBox "対象のファイルがありません。"
Exit Sub
End If
　
Do While myfile <> ""

Workbooks(myfile).Activate

Dim i As Long
　For i = 1 To Sheets.Count
　　If Sheets(i).Visible = True Then
　　　Sheets(i).Select Replace:=False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
　　Filename:=Left(Workbooks(myfile).FullName, InStrRev(Workbooks(myfile).FullName, ".")) & "pdf"

End If
Next

Workbooks(myfile).Close SaveChanges:=True　 'ブックを閉じる
myfile = Dir
　
Loop

If Dir("〇〇〇★★★AAA", vbDirectory) <> "" Then
　CreateObject("Shell.Application").Open "〇〇〇★★★AAA"
ElseIf Dir("〇〇〇★★★BBB", vbDirectory) <> "" Then
　CreateObject("Shell.Application").Open "〇〇〇★★★BBB"
End If

End Sub

〇★AorBの所をあらかじめ入れておけばちゃんと動くのですが、
★を変動できるように

Sub 指定フォルダーのExcelファイルを全て開く()

Dim myPath As String, myfile As String
Dim myPath1 As String, myPath2 As String, myPath3 As String
Dim myNum As String
　myNum = Range("E10").Text

If ThisWorkbook.Sheets(1).Range("B8") = "" Then
　MsgBox "数字の入力は必須です!"
　Exit Sub
End If

myPath = "〇〇〇"
myPath1 = myPath & myNum & "AAA\"
myPath2 = myPath & myNum & "BBB\"

If Dir(myPath1, vbDirectory) <> "" Then
　myPath3 = myPath1
ElseIf Dir(myPath2, vbDirectory) <> "" Then
　myPath3 = myPath2
Else
MsgBox "対象のファイルがありません。"
Exit Sub
End If
　
　myfile = Dir(myPath & "*.xlsx*")
　　　
　Do
　　Workbooks.Open Filename:=myPath & "\" & myfile
　　
　Dim i As Long
　For i = 1 To Sheets.Count
　　If Sheets(i).Visible = True Then
　　　Sheets(i).Range("H4") = ThisWorkbook.Sheets(1).Range("B8").Text
　　　
　 End If
　　
　Next i
　　myfile = Dir
　Loop Until myfile = ""　
Call pdfに出力
　
End Sub
---------------------------------------------------------------------
Sub pdfに出力()
Dim myPath As String, myfile As String
Dim myPath1 As String, myPath2 As String, myPath3 As String
Dim myNum As String
　myNum = Range("E10").Text

If ThisWorkbook.Sheets(1).Range("B8") = "" Then
　MsgBox "数字の入力は必須です!"
　Exit Sub
End If

myPath = "〇〇〇"
myPath1 = myPath & myNum & "AAA\"
myPath2 = myPath & myNum & "BBB\"

End If
　
myfile = Dir(myPath & "*.xlsx*")

　
Do While myfile <> ""

Workbooks(myfile).Activate

Dim i As Long
　For i = 1 To Sheets.Count
　　If Sheets(i).Visible = True Then
　　　Sheets(i).Select Replace:=False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
　　Filename:=Left(Workbooks(myfile).FullName, InStrRev(Workbooks(myfile).FullName, ".")) & "pdf"

End If
Next

Workbooks(myfile).Close SaveChanges:=True　 'ブックを閉じる
myfile = Dir
　
Loop

CreateObject("Shell.Application").Open myPath3
End If

End Sub

とすると、ファイルが開いてセルに値が入るまではうまくいきますが、
PDFに書き出したり、保存して閉じるをやってくれずに終了します。

最初のパスを直接指定している時と、変動でも出来るようにしている時と何が違うのでしょうか?

何かお気づきの点あればご示唆お願い致します。

1 hits

▼

【81660】フォルダパスが変動しても対応したい。 のっち 21/2/14(日) 22:12