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


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

よろしくお願いします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2014/01/28 23:01:28
  • 終了:2014/01/31 17:41:41

ベストアンサー

id:gong1971 No.1

gong1971回答回数443ベストアンサー獲得回数682014/01/30 16:40:59

ポイント700pt

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

きれいなソースではなく、お恥ずかしいですが…
コード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
id:sunfkin22

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

2014/01/31 17:41:20
id:gong1971

はい、無事解決して良かったです!

2014/01/31 18:10:19
  • id:sunfkin22
    初歩的なことですが、
    1.画像の拡張子がすべてに対応するようにするにはどう修正したらいいでしょう?
    2.コード1が、「!73C301B3」の場合、36行目で止まってしまいます。

    再度、ご教示の程、お願い致します。
      
  • id:sunfkin22
    「!73C301B3」の問題は、リストの誤りを修正することで解決できました。

    2度、3度実行した場合に「実行時エラー '58'」既に同名のファイルが存在します。とでます。
    こちらは、ファイルを追加した際にも続きからリネームと振り分けができるようになりますでしょうか?

    度々の要望ですが、よろしくお願い致します。
  • id:gong1971
    元々、2度3度実行した場合にも続きの番号からリネームを行うようになっています。回答前に簡単なテストを行っており、動作を確認しています。

    「既に同名のファイルが存在します」というエラーが発生する状況が想像できないので、テスト用のコードを入れて実行して頂けますか?

    最後の方、下記行の後に、
    >>
    If i > 0 And i < 1000 Then
    <<

    次のコードを入れて実行してください。
    >>
    Debug.Print pictdir & dd & " # " & rendir & pn & "\" & pn & "_" & Format(i, "000") & "." & px
    <<

    エラーが起きた際、イミディエイトウィンドウ(*1)の一番最後の行をお知らせください。商品名など都合が悪い場合は、適宜変更してお知らせください。その際、記号が含まれるようであれば、記号だけは変更しないでください。

    (*1)
    イミディエイトウィンドウは、VBA画面の下部に表示されます。表示されていない場合は、[Ctrl]+[G]で表示されます。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません