サブフォルダ内のファイル名をVBAで変更する

Question

それぞれのファイルをSharePointに数百個アップロードしようとしていますが、残念ながらSharePointでは「％」のような特殊文字は使用できません。

私はこれまでのところ私が持っているものなど、自動的に各サブフォルダに移動して、このような「％」、「＃」などのファイル内に含まれる任意の特殊文字を置き換えることができますVBAコードを使用する

をしようとしている

次のとおりです。

Sub ChangeFileName() 

Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set Folder = objFSO.GetFolder("C:\Users\Documents\TEST\Subfolder") 
'Currently the way I have it requires me to change my path a few hundred times 
For Each File In Folder.Files 
    sNewFile = File.Name 
    sNewFile = Replace(sNewFile, "%", "_") 
    sNewFile = Replace(sNewFile, "#", "_") 
'^and so on` 
    If (sNewFile <> File.Name) Then 
     File.Move (File.ParentFolder + "\" + sNewFile) 
    End If 

Next 

End Sub 

しかし上記のスクリプトのために、あなたは特定のサブフォルダパスを必要としています。サブフォルダ内のファイルの特殊文字を自動的に置き換える方法があるかどうかわかりません。 ExcelワークシートのA列に、特定のサブフォルダのパスをすべてペーストすることもできます。

ありがとうございました！

Answer 1

私はこのことができます場合

Sub GetFileFromFolder() 

    Dim fd As FileDialog 
    Dim strFolder As String 
    Dim colResult As Collection 
    Dim i As Long, k As Long 
    Dim vSplit 
    Dim strFn As String 
    Dim vR() As String 
    Dim p As String 
    Dim iLevel As Integer, cnt As Long 



    'iLevel = InputBox(" Subfolder step : ex) 2 ") 
     p = Application.PathSeparator 
     Set fd = Application.FileDialog(msoFileDialogFolderPicker) 
     With fd 
      .Show 
      .InitialView = msoFileDialogViewList 
      .Title = "Select your Root folder" 
      .AllowMultiSelect = False 

      If .SelectedItems.Count = 0 Then 
      Else 
       strFolder = .SelectedItems(1) 
       Set colResult = SearchFolder(strFolder) 

       i = colResult.Count 

       For k = 1 To i 

        vSplit = Split(colResult(k), p) 
        strFn = vSplit(UBound(vSplit)) 
        strFn = Replace(strFn, "%", "_") 
        strFn = Replace(strFn, "#", "_") 

        'If UBound(vSplit) - UBound(Split(strFolder, p)) = iLevel Then 
         cnt = cnt + 1 
         ReDim Preserve vR(1 To 3, 1 To cnt) 
         On Error Resume Next 
         Err.Clear 
         Name colResult(k) As strFolder & strFn 
         vR(1, cnt) = colResult(k) 

         If Err.Number = 58 Then 
          strFn = Split(strFn, ".")(0) & "_" & vSplit(UBound(vSplit) - 1) & "_" & Date & "." & Split(strFn, ".")(1) 
          Name colResult(k) As strFolder & strFn 
          vR(2, cnt) = strFolder & strFn 
          vR(3, cnt) = "Changed name " 'When filename is duplicated chage filename 
         Else 
          vR(2, cnt) = strFolder & strFn 
         End If 
        ' End If 
       Next k 

       ActiveSheet.UsedRange.Offset(1).Clear 
       Range("a3").Resize(1, 3) = Array("Old file", "New file", "Ect") 
       If cnt > 0 Then 
        Range("a4").Resize(cnt, 3) = WorksheetFunction.Transpose(vR) 
       End If 
       With ActiveSheet.UsedRange 
        .Borders.LineStyle = xlContinuous 
        .Columns.AutoFit 
        .Font.Size = 9 
       End With 
      End If 
     End With 
     MsgBox cnt & " files moved!! " 
End Sub 
Function SearchFolder(strRoot As String) 
    Dim FS As Object 

    Dim fsFD As Object 
    Dim f As Object 
    Dim colFile As Collection 
    Dim p As String 

    On Error Resume Next 
    p = Application.PathSeparator 
    If Right(strRoot, 1) = p Then 
    Else 
     strRoot = strRoot & p 
    End If 

    Set FS = CreateObject("Scripting.FileSystemObject") 
    Set fsFD = FS.GetFolder(strRoot) 
    Set colFile = New Collection 
    For Each f In fsFD.Files 
     colFile.Add f.Path 
    Next f 

     SearchSubfolder colFile, fsFD 


    Set SearchFolder = colFile 
    Set fsFD = Nothing 
    Set FS = Nothing 
    Set colFile = Nothing 

End Function 
Sub SearchSubfolder(colFile As Collection, objFolder As Object) 
    Dim sbFolder As Object 
    Dim f As Object 
    For Each sbFolder In objFolder.subfolders 
     SearchSubfolder colFile, sbFolder 
     For Each f In sbFolder.Files 
      colFile.Add f.Path 
     Next f 
    Next sbFolder 

End Sub