| |
行いたい事はデスクトップ上にあるとあるフォルダーの中にいくつかエクセルファイルがあります。(ファイル名が違うだけで同じ様な形)。
そのフォルダー内のファイルを全部開いて同じセルに決められた文字を入れた後、
それぞれ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に書き出したり、保存して閉じるをやってくれずに終了します。
最初のパスを直接指定している時と、変動でも出来るようにしている時と何が違うのでしょうか?
何かお気づきの点あればご示唆お願い致します。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
