ファイル名・フォルダ名の一部をセルの値へ変更したい。

Question

お世話になります。
エラーが解消できず行き詰っているためご教示お願いいたします。
下記コード実行時、「ファイル名を変更して保存」のSaveAsの部分で実行時エラー：オートメーションエラー　となります。

実現したい動作

・C\AAA\BBB\CCC\DDD\保存フォルダ　にサブフォルダ”000000000(111)氏名”が10件前後あるものとします。
・サブフォルダ内には【資料】000000000(111)氏名.xlsx　というファイルが必ず存在しており、”00000000(111)氏名”の部分は必ず一致しています。

1． サブフォルダ内のファイル【資料】000000000(111)氏名.xlsxを開く
2． G14の値を変数numへ格納
3． numを半角へ変換
4． サブフォルダ名とファイル名の（）内の値をnumの値に置換

Sub　置換作業()

Dim buf As String 　　‘サブフォルダ名
Dim cnt As Long　　　’サブフォルダカウント用
Dim wb As Workbook　‘【資料】～.xlsxファイル
Dim ws As Worksheet　‘上記ファイルの指定シート
Dim num As String　　‘上記シートのセル値
Dim FileName_1 As Variant　‘【資料】ファイルの分割（前半）
Dim e As Long　　　　　　　‘bufの後ろ括弧の文字位置
Dim FileName_2 As Variant　‘【資料】ファイルの分割（後半）
Dim New_wb As Variant　　‘新規ファイル名
Dim New_fol As String　　　‘num置換後のサブフォルダ

Const Path As String = ” C\AAA\BBB\CCC\DDD\保存フォルダ\

With Application
.ScreenUpdating=False
.DisplayAlerts=False
End With

buf = Dir(Path,vbDirectory)
cnt = 1

‘保存フォルダの中のサブフォルダを開く
Do While buf  <>””

‘・と・・のフォルダは処理を飛ばす
If  buf  <> ”.”  And buf  <> “..” Then

ChDir　Path
Set wb = Workbooks.Open(Path & buf & “【資料】” & buf & “.xlsx”)
Wb.Activate
Set ws = wb.Sheets(“Sheet1”)

‘G14セルの値を変数numへ格納
num = ws.Cells(14,7)

‘numを半角変換
Cells(14,7) = StrConv(num,vbNarrow)
num = Cells(14,7).Value

‘新規ファイル名を作成
FileName_1 = Left(buf,16)

e = InStrRev(buf,”)”)
FileName_2 = Mid(buf,e)

‘サブフォルダ名を修正
‘※同名フォルダがすでに存在する場合（）の中の値とnum（※半角）が完全一致する場合には処理を飛ばす⇒ファイル名の変更も不要
New_fol = Path  & FileName_1 & num & FileName_2
If Path & buf = New_fol Then GoTo Jump

Name Path & buf As New_fol

Jump:

‘ファイル名を変更して保存
New_wb = New_fol & “【資料】” & FileName_1 & num & FileName_2 & “.xlsx”
wb.SaveAs New_wb
wb.Close False

End If

cnt = cnt + 1
 buf = Dir()

Loop

With Application
.ScreenUpdating=True
.DisplayAlerts=True
End With

End Sub

Comments

[haru4]

Usirow様　お返事ありがとうございます。
‘ファイル名を変更して保存
New_wb = New fol & “【資料】” & FileName_1 & num & FileName_2 & “.xlsx”
wb.SaveAs New_wb　←ここで標題の通り、オートメーションエラーとでます。

誤字失礼いたしました。
実際のコードは　New_fol　となっています。

[Usirow]

すみません。先に聞くべきでしたが、そもそもどんなエラーメッセージが出ていますか？

[haru4]

失礼いたしました。
何度か試行してみたところ、エラーの表示が変わりまして
'フォルダの中の【調査依頼書】～.xlsxを開く
ChDir Path
Set wb = Workbooks.Open(Path & buf & "\【資料】" & buf &".xlsx")　←この部分で
‘実行時エラー1004’
C\AAA\BBB\CCC\DDD\保存フォルダ\【資料】0000000(111)氏名.xlsxにアクセスできません。
と出ています…。

[haru4]

追記
度々失礼いたします。
保存フォルダの上から13番目のサブフォルダの動作の途中にエラーになっているようです。
また、動作済のサブフォルダ内を１件ずつ確認したところ、【資料】～ファイルが消えてしまっていたので、ファイルが見つからないというエラーが出ているのかと．．．
恐らく置換後のパス指定から大きく間違いがあるように思います。

[haru4]

'修正後ファイルを保存　の最後に
作成段階で加えた Kill New_fol & "\【資料】" & buf & ".xlsx"
の記述が残っていたため、元ファイルが削除されていたようでした。（当然ですね・・・）
この部分をコードから削除し、サブフォルダへファイルを作成し直しましたが
それでも尚、‘実行時エラー1004’ C\AAA\BBB\CCC\DDD\保存フォルダ\【資料】0000000(111)氏名.xlsxにアクセスできません。
が表示されております。

度々申し訳ございませんが、お力添え頂けますと幸いです。

[Usirow]

そのC\AAA~というパスは、C:\AAA~の間違いではないですか？

Answer 1

駄作ですが、解決しましたので載せておきます。

Sub　置換作業()

Dim buf As String 　　‘サブフォルダ名
Dim cnt As Long　　　’サブフォルダカウント用
Dim wb As Workbook　‘【資料】～.xlsxファイル
Dim ws As Worksheet　‘上記ファイルの指定シート
Dim num As String　　‘上記シートのセル値
Dim FileName_1 As Variant　‘【資料】ファイルの分割（前半）
Dim e As Long　　　　　　　‘bufの後ろ括弧の文字位置
Dim FileName_2 As Variant　‘【資料】ファイルの分割（後半）
Dim New_wb As Variant　　‘新規ファイル名
Dim fso　As Object
Dim New_fol As String　　　‘num置換後のサブフォルダ

Const Path As String = ” C:\AAA\BBB\CCC\DDD\保存フォルダ\

Set fso = CreateObject("Scripting.FileSystemObject")

With Application
.ScreenUpdating=False
.DisplayAlerts=False
End With

buf = Dir(Path,vbDirectory)
cnt = 1

‘保存フォルダの中のサブフォルダを開く
Do While buf  <>””

‘・と・・のフォルダは処理を飛ばす
If  buf  <> ”.”  And buf  <> “..” Then

ChDir　Path
Set wb = Workbooks.Open(Path & buf & “【資料】” & buf & “.xlsx”)
Wb.Activate
Set ws = wb.Sheets(“Sheet1”)
num = ws.Cells(14,7)

‘numを半角変換
Cells(14,7) = StrConv(num,vbNarrow)
num = Cells(14,7).Value

‘新規ファイル名を作成
FileName_1 = Left(buf,16)
e = InStrRev(buf,”)”)
FileName_2 = Mid(buf,e)

‘新規フォルダ名・ファイル名を定義
New_fol = Path & FileName_1 & num & FileName_2
New_wb = New_fol & “【資料】” & FileName_1 & num & FileName_2 & “.xlsx”

‘ファイルが存在した場合の処理
If fso.FolderExsists(New_fol) Then
wb.Close False

End If

‘ファイルが存在しない場合の処理
If Not fso.FolderExsists(New_fol) Then
Name Path & buf & As New_fol
wb.SaveAs New_wb
wb.Close False
Kill New_fol & “\【資料】” & buf & “.xlsx”

End If
 End If

cnt = cnt + 1
 buf = Dir()

Loop

‘処理の高速化を解除
With Application
.ScreenUpdating=True
.DisplayAlerts=True
End With

End Sub