05. december 2010 - 06:54Der er
10 kommentarer og 1 løsning
omdøb mapper
Hej
Jeg skal lave en masse mapper hvor der ligger en fil f.eks.:
Mappe 1= "tilbud 1" og den skal så indeholde en fil der hedder "tilbud 1"(excel fil) Mappe 2= "tilbud 2" og den skal så indeholde en fil der hedder "tilbud 2"(excel fil)
Jeg har fået hjælp til at lave denne macro: Sub VælgSti() Dim x As FileDialog Set x = Application.FileDialog(msoFileDialogFolderPicker) x.Show sti = x.SelectedItems(1) sti = sti & "\" Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Clear Range("A1") = sti fil = Dir(sti) Do While fil <> "" rk = rk + 1 Cells(rk + 1, 1) = fil Cells(rk + 1, 2) = fil fil = Dir Loop End Sub
Sub Omdøb() sti = Range("A1").Value For Each c In Range("A2:A" & Cells(5000, 1).End(xlUp).Row) Name sti & c.Value As sti & c.Offset(0, 1).Value Next End Sub
Og den kan omdøbe en masse filer, men kan den laves om så den kan omdøbe en masse mapper. og kan man lave en macro der ligger en fil i hver mappe.
Denne side indeholder artikler med forskellige perspektiver på Identity & Access Management i private og offentlige organisationer. Artiklerne behandler aktuelle IAM-emner og leveres af producenter, rådgivere og implementeringspartnere.
Her er det jeg har tilrettet. og når jeg bruger den så skriver jeg de gamle filnavne i a1 og så der nedad, og de nye navne i b2 og så der nedad. og er aktiv i A1
'Const drevSTi = "C:\Documents and Settings\pb.KHNBPB\Skrivebord\renameMapper\drev" 'JUSTERES Const drevSTi = "C:\Users\Kennet Pedersen\Desktop\Prøve" 'JUSTERES Dim antalRækker As Long, mapNavn As String, filNavn As String, nytNavn As String Public Sub renameSystem() antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
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
nytNavn = findNytNavn(fNavn) If nytNavn <> "" Then f1.Name = nytNavn & ext End If Next End Sub Private Function findNytNavn(ptNavn) With ActiveWorkbook.ark(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
Jeg ligger lige din løsning her, hvis andre også ville have glæde af den:
'Const drevSTi = "C:\Documents and Settings\pb.KHNBPB\Skrivebord\Omdøb_925724" 'JUSTERES Const drevSTi = "C:\Users\Kennet Pedersen\Desktop\Prøve" 'JUSTERES Dim antalRækker As Long, mapNavn As String, filNavn As String, nytNavn As String Public Sub renameSystem() antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
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
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
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
