Rename mapper og undermapper samt filer

Det skulle muligt via VBA - f.eks. med basis i et Excel ark, hvor gl. og nye navn kan defineres.

OK :-)

Kan jeg lokke dig til at komme med et eksempel? for det er jeg ikke helt med på...

Jeg skal prøve - men det kan vare lidt p.g.a. aktuel kundeopgave.

Du nævner filer i overskriften, men kan ikke se hvad der skal gøres ved disse?

Hej

det gælder det samme for filer som for mapperne, at de skal omdøbes. Det er dog ikke så væsentligt som det er for mapperne, men alligevel rart hvis det kan lade sig gøre med det samme

PFT

ok - regel for filer - samme som mapper - eller?

Hej - det er de samme regler der er gældende for mapper, undermapper og filer

ok - forsøger at konstruere et eksempel..

1000 tak

Hvis du sender en mail - kan jeg returnere hele modellen med mappe-strukturen inkl. filer. @-adresse under profil.


Nedenstående VBA er anbragt under ark1 i Excel-fil:

Const drevSTi = "C:\Documents and Settings\pb.KHNBPB\Skrivebord\renameMapper\drev"      'JUSTERES
Dim antalRækker As Long, mapNavn As String, filNavn As String, nytNavn As String
Public Sub renameSystem()
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    mapNavn = ""
    filNavn = ""
   
    traverserDrev drevSTi
   
    MsgBox mapNavn, vbOKOnly, "Fundne Mapper"
    MsgBox filNavn, vbOKOnly, "Fundne Filer"
   
End Sub
Private Sub traverserDrev(mappenavn)
    Dim fs, f, f1, fc
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappenavn)
    Set fc = f.SubFolders
   
    For Each f1 In fc
        mapNavn = mapNavn & f1.Name & vbCrLf
       
        findFiler f1.Path, f1.Name
       
Rem RENAMNE via opslag i Excel-ark
        nytNavn = findNytNavn(f1.Name)
        If nytNavn <> "" Then
            f1.Name = nytNavn
        End If
       
        traverserDrev f1
    Next
End Sub
Private Sub findFiler(mappesti, mappe)
Dim fs, f, f1, fc, fNavn As String, ext As String, navnSplit As Variant

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappesti)
    Set fc = f.Files
   
    For Each f1 In fc
        filNavn = filNavn & mappe & "\" & f1.Name & vbCrLf
       
        navnSplit = Split(f1.Name, ".")
        fNavn = navnSplit(0)
        ext = "." & navnSplit(1)
       
        nytNavn = findNytNavn(fNavn)
        If nytNavn <> "" Then
            f1.Name = nytNavn & ext
        End If
    Next
End Sub
Private Function findNytNavn(ptNavn)
    With ActiveWorkbook.Sheets(1).Range("A1:A" & antalRækker)
        Set c = .find(ptNavn, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findNytNavn = Range("B" & c.Row)
        Else
            findNytNavn = ""
        End If
    End With
End Function

Hej

det er fuldstændigt som det skal være, jeg er 100% tilfreds......

der har du sparet mig rigtig mange timers arbejde

Smider du et svar

Fint -

Kanon service