人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

ExcelのVBA:大量の画像ファイルのリネームと自動フォルダ分けを次の条件でできませんでしょうか?

・元の画像ファイル名は、コード1_コード2 とファイル名がついている
・Excelのシートには、コード1、商品名1、商品名2のリスト一覧表がある
・リネーム後のファイル名は、コード1を元に、
商品名1_商品名2_No(001〜の3桁の連番)にしたい
・商品名1_商品名2でフォルダを生成して、自動振り分けをしたい
・フォルダ生成は、「リネームファイル」フォルダの中に作りたい
・リスト一覧表になければ、ファイル名は変更せず、フォルダ分けもしない

よろしくお願いします。

●質問者: にゃんころね
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● gong1971
●700ポイント ベストアンサー

※途中、回答に誤りがありましたが、修正完了しました。

きれいなソースではなく、お恥ずかしいですが…
コード1、商品名1、商品名2のリスト一覧表のシートをアクティブにして実行してください。

下記項目については、ソース上部で適宜変更してご使用ください。

・画像ファイルのパス、リネームファイルのパス
・Excelシートのコード1の範囲
・画像ファイルの拡張子がjpgでない場合

※コード1、商品名1、商品名2は連続した列(例:A列、B列、C列)とします
※連番が999を超えた場合は、ファイル名の変更、フォルダ分けをしません

以上、不明な点がありましたら、コメントにてお知らせください。

Option Explicit

Sub Macro1()

Dim pictdir As String
Dim rendir As String
Dim dd As String
Dim dr As String
Dim cn As String
Dim pn As String
Dim px As String
Dim ps As Long
Dim i As Integer
Dim obj As Object
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'### 画像ファイルのパス 最後は\
pictdir = "C:\Users\user\Desktop\pict\pict\"
'### リネームファイルのパス 最後は\
rendir = "C:\Users\user\Desktop\pict\リネームファイル\"
'### コード1の範囲
dr = "A1:A3"
'### 画像ファイルの拡張子
px = ".jpg"

dd = Dir(pictdir & "*" & px)
Do Until dd = ""
 ps = InStr(dd, "_")
 If ps > 0 Then
 cn = Left(dd, ps - 1)
 Set obj = Range(dr).Cells.Find(cn)
 If Not obj Is Nothing Then
 pn = obj.Offset(0, 1) & "_" & obj.Offset(0, 2)
 If FSO.FolderExists(rendir & pn) = False Then
 MkDir rendir & pn
 End If
 
 For i = 1 To 999
 If FSO.FileExists(rendir & pn & "\" & pn & "_" & Format(i, "000") & px) = False Then
 Exit For
 End If
 Next
 
 If i > 0 And i < 1000 Then
 Name pictdir & dd As rendir & pn & "\" & pn & "_" & Format(i, "000") & px
 End If
 End If
 End If
 dd = Dir()
Loop

End Sub


全ての拡張子に対応するように変更を行いました。

なお、画像ファイルかどうかは判断できないので、フォルダ内のすべてのファイルを処理します。ただし、ファイル名に _ が含まれないもの、_ が含まれてもコード1に対応するコードがリストに無いものは、処理の段階ではじかれます。(コード1がリストにあると、ExcelやWordのファイルも処理対象となります)

《コード1が、「!73C301B3」の場合、36行目で止まってしまいます。》との事ですが、下記の情報を教えてください。

・36行目のVBAの記述
・エラーメッセージ
・!73C301B3 に対応する商品名1、商品名2
※この商品名1、商品名2ですが、ファイル名に使用できない文字が含まれていませんか?
含まれている場合、どのように処理をしますか?
→とりあえずの対処として、リストからファイル名に使用できない文字は
置換で取り除いてはいかがでしょうか?

Sub Macro2()

Dim pictdir As String
Dim rendir As String
Dim dr As String
Dim dd As String
Dim cn As String
Dim pn As String
Dim px As String
Dim fn As Integer
Dim ps As Long
Dim i As Integer
Dim ddo As Object
Dim obj As Object
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'### 画像ファイルのパス 最後は\
pictdir = "C:\Users\user\Desktop\pict\pict\"
'### リネームファイルのパス 最後は\
rendir = "C:\Users\user\Desktop\pict\リネームファイル\"
'### コード1の範囲
dr = "A1:A3"

For Each ddo In FSO.GetFolder(pictdir).Files
 dd = ddo.Name
 ps = InStr(dd, "_")
 If ps > 0 Then
 cn = Left(dd, ps - 1)
 Set obj = Range(dr).Cells.Find(cn)
 If Not obj Is Nothing Then
 pn = obj.Offset(0, 1) & "_" & obj.Offset(0, 2)
 If FSO.FolderExists(rendir & pn) = False Then
 MkDir rendir & pn
 End If
 
 px = FSO.GetExtensionName(dd)
 For i = 1 To 999
 If Dir(rendir & pn & "\" & pn & "_" & Format(i, "000") & ".*") = "" Then
 Exit For
 End If
 Next
 
 If i > 0 And i < 1000 Then
 Name pictdir & dd As rendir & pn & "\" & pn & "_" & Format(i, "000") & "." & px
 End If
 End If
 End If
Next

End Sub

にゃんころねさんのコメント
画像自体に問題がったためと分かりました。 とても重宝しておりますので、ポイントは加算させてもらいます。 誠に、ありがとうございました!

gong1971さんのコメント
はい、無事解決して良かったです!
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ