web-dev-qa-db-ja.com

フォルダをループし、VBAを使用して特定の条件を満たすファイルの名前を変更しますか？

私はVBAを初めて使用しますが（Javaのトレーニングは少ししかありません）、ここにある他の投稿の助けを借りてこのコードを組み立て、壁にぶつかりました。

フォルダー内の各ファイルを循環するコードを記述して、各ファイルが特定の基準を満たしているかどうかをテストしようとしています。基準が満たされている場合は、ファイル名を編集して、同じ名前の既存のファイルを上書き（または以前に削除）する必要があります。次に、これらの新しく名前が変更されたファイルのコピーを別のフォルダーにコピーする必要があります。私は非常に近いと思いますが、私のコードはすべてのファイルを循環することを拒否したり、実行時にExcelをクラッシュさせたりします。助けてください？ :-)

Sub RenameImages()

Const FILEPATH As String = _
"C:\\CurrentPath"
Const NEWPATH As String = _
"C:\\AditionalPath"


Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String

Dim FileExistsbol As Boolean

Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")

strfile = Dir(FILEPATH)

Do While (strfile <> "")
  Debug.Print strfile
  If Mid$(strfile, 4, 1) = "_" Then
    fprefix = Left$(strfile, 3)
    fsuffix = Right$(strfile, 5)
    freplace = "Page"
    propfname = FILEPATH & fprefix & freplace & fsuffix
    FileExistsbol = FileExists(propfname)
      If FileExistsbol Then
      Kill propfname
      End If
    Name FILEPATH & strfile As propfname
    'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
  End If

  strfile = Dir(FILEPATH)

Loop

End Sub

役立つ場合、ファイル名はABC_mm_dd_hh_Page _＃。jpgで始まり、目標はそれらをABCPage＃.jpgに切り詰めることです。

ありがとうSOどうも！

excelvbaexcel-vbaexcel-2013
5
Joe K

特に名前を変更する場合は、処理を開始する前に、まず配列またはコレクション内のすべてのファイル名を収集することをお勧めします。そうでない場合は、Dir（）を混乱させないという保証はなく、ファイルをスキップしたり、「同じ」ファイルを2回処理したりします。また、VBAでは、文字列の円記号をエスケープする必要はありません。

コレクションを使用した例を次に示します。

Sub Tester()

    Dim fls, f

    Set fls = GetFiles("D:\Analysis\", "*.xls*")
    For Each f In fls
        Debug.Print f
    Next f

End Sub



Function GetFiles(path As String, Optional pattern As String = "") As Collection
    Dim rv As New Collection, f
    If Right(path, 1) <> "\" Then path = path & "\"
    f = Dir(path & pattern)
    Do While Len(f) > 0
        rv.Add path & f
        f = Dir() 'no parameter
    Loop
    Set GetFiles = rv
End Function
3
Tim Williams

編集：代替ソリューションについては、以下の更新を参照してください。

コードには1つの大きな問題があります。Loopの終わりの前の最後の行は

_   ...
   strfile = Dir(FILEPATH)  'This will always return the same filename

Loop
...
_

コードは次のようになります。

_   ...
   strfile = Dir()  'This means: get the next file in the same folder

Loop
...
_

Dir()を最初に呼び出すときは、ファイルを一覧表示するパスを指定する必要があるため、ループに入る前に次の行を指定します。

_strfile = Dir(FILEPATH)
_

いいね。この関数は、そのフォルダー内の条件に一致する最初のファイルを返します。ファイルの処理が終了し、次のファイルに移動する場合は、パラメーターを指定せずにDir()を呼び出して、次のファイルへの反復に関心があることを示す必要があります。

=======

別の解決策として、オペレーティングシステムでオブジェクトを作成する代わりに、VBAに提供されているFileSystemObjectクラスを使用できます。

まず、[ツール]-> [参照]-> [Microsoft Scripting Runtime]に移動して、「MicrosoftScriptingRuntime」ライブラリを追加します。

enter image description hereenter image description here

[Microsoft Scripting Runtime]がリストに表示されていない場合は、_C:\windows\system32\scrrun.dll_を参照するだけで、同じことができます。

次に、参照されているライブラリを利用するようにコードを次のように変更します。

次の2行：

_Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
_

次の1行に置き換える必要があります。

_Dim fso As New FileSystemObject
_

次に、コードを実行します。それでもエラーが発生する場合は、少なくとも今回は、以前のあいまいなオブジェクトによって提供された一般的なエラーとは異なり、エラーにはその発生源に関する詳細が含まれているはずです。

3
Ahmad

誰かが疑問に思っている場合のために、これが私の完成したコードです。ティムとアフマドの助けに感謝します！

Sub RenameImages()

Const FILEPATH As String = "C:\CurrentFilepath\"
Const NEWPATH As String = "C:\NewFilepath\"


Dim strfile As String
Dim freplace As String
Dim fprefix As String
Dim fsuffix As String
Dim propfname As String
Dim fls, f

Set fls = GetFiles(FILEPATH)
For Each f In fls
    Debug.Print f
    strfile = Dir(f)
      If Mid$(strfile, 4, 1) = "_" Then
        fprefix = Left$(strfile, 3)
        fsuffix = Right$(strfile, 5)
        freplace = "Page"
        propfname = FILEPATH & fprefix & freplace & fsuffix
        FileExistsbol = FileExists(propfname)
          If FileExistsbol Then
          Kill propfname
          End If
        Name FILEPATH & strfile As propfname
        'fso.CopyFile(FILEPATH & propfname, NEWPATH & propfname, True)
      End If
Next f
End Sub

Function GetFiles(path As String, Optional pattern As String = "") As Collection
    Dim rv As New Collection, f
    If Right(path, 1) <> "\" Then path = path & "\"
    f = Dir(path & pattern)
    Do While Len(f) > 0
        rv.Add path & f
        f = Dir() 'no parameter
    Loop
    Set GetFiles = rv
End Function

Function FileExists(fullFileName As String) As Boolean
    If fullFileName = "" Then
        FileExists = False
    Else
        FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
    End If
End Function
1
Joe K