FSO フォルダ名変更指定文字を先頭に付加させる

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][FSO フォルダ名変更指定文字を先頭に付加させる]
Option Explicit


Sub SetScrrunDLL()
'*****************************************************
'このコードが実装されたブックが「FileSystemObject」
'が使えるように参照設定をする。
'*****************************************************
On Error GoTo MyERROE:
'参照設定
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\system32\scrrun.dll"
MyERROE:
End Sub



Sub フォルダ名変更()
'*****************************************************
'指定文字を先頭に付加(追加)させる
'*****************************************************
'対象は同階層フォルダ
'結果を新しいシートを追加し一覧表示

Dim Fso As FileSystemObject
Dim sht As Worksheet, Nsht As Worksheet
Dim lIndex As Long
Dim hFolder As Folder
Dim subFolder As Folder
Dim FukaName As String
Dim MotoName As String
Dim PathName As String

Set Fso = New FileSystemObject
Set hFolder = Fso.GetFolder(ThisWorkbook.Path & "\")
Set sht = ThisWorkbook.Worksheets("Sheet1")
Set Nsht = ThisWorkbook.Worksheets.Add

PathName = ThisWorkbook.Path & "\"

With sht
    FukaName = .Cells(2, 1).Value
End With

With Nsht
    .Cells.ClearContents
    lIndex = 0
        lIndex = lIndex + 1
        .Cells(lIndex, 1).Value = "Index"
        .Cells(lIndex, 2).Value = "旧名"
        .Cells(lIndex, 3).Value = "新名"
        For Each subFolder In hFolder.SubFolders
            lIndex = lIndex + 1
            .Cells(lIndex, 1).Value = lIndex - 1
            MotoName = subFolder.Name
            .Cells(lIndex, 2).Value = MotoName

            Set Fso = CreateObject("Scripting.FileSystemObject")
            'フォルダの名前を変更
            Fso.GetFolder(PathName & MotoName).Name = FukaName & MotoName
            Set Fso = Nothing

            .Cells(lIndex, 3).Value = FukaName & MotoName
        Next subFolder
End With

Set Fso = Nothing
Set hFolder = Nothing
Set sht = Nothing

MsgBox "END"
End Sub





Production Japan Import Application. Since 1998