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 cntdel As Long
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
    cntdel = .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 = Mid(MotoName, cntdel + 1)
            Set Fso = Nothing

            .Cells(lIndex, 3).Value = Mid(MotoName, cntdel + 1)
        Next subFolder
End With

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

MsgBox "END"
End Sub





Production Japan Import Application. Since 1998