[ vojvoda1010 @ 15.10.2019. 20:58 ] @
Da li neko ima VBA da se pomocu excel preimenuju FOLDER-i, ne FILE-ovi.

Nasao sam neki vba ali za FILE, da li on moze da se preradi, stavljam sam deo vba



Sub RenameFiles()
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Range("Filelist").Offset(1, 0).Select
RowCounter = 0
Unchanged = 0
If ActiveCell.Value = "" Then
MsgBox "No files detected", vbInformation, "Rename files"
Exit Sub
End If
MyPath = Range("Path").Value
If MyPath = "" Then
Application.ScreenUpdating = True
MsgBox "No Path specified", vbInformation, "Rename files"
Exit Sub
End If
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
On Error GoTo BadFile
Do
If ActiveCell.Offset(RowCounter, 0).Interior.ColorIndex <> RenamedColour Then
NextFile = MyPath & ActiveCell.Offset(RowCounter, 0)
ChangeTo = MyPath & ActiveCell.Offset(RowCounter, 4)
RowCounter = RowCounter + 1
If NextFile = ChangeTo Then
Range("B" & RowCounter + Range("Filelist").Row & ":F" & RowCounter + Range("Filelist").Row).Interior.ColorIndex = UnchangedColour
Range("E" & RowCounter + Range("Filelist").Row).Value = "U"
Unchanged = Unchanged + 1
Else
Name NextFile As ChangeTo
Range("B" & RowCounter + Range("Filelist").Row & ":F" & RowCounter + Range("Filelist").Row).Interior.ColorIndex = RenamedColour
Range("E" & RowCounter + Range("Filelist").Row).Value = "R"
End If
Else
RowCounter = RowCounter + 1
End If
Loop Until ActiveCell.Offset(RowCounter, 0).Value = ""
Application.ScreenUpdating = True
MsgBox RowCounter - Unchanged & " files renamed" & Chr(13) & Unchanged & " files unchanged", vbInformation, "Rename files"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True
Exit Sub
BadFile:
Range("B" & RowCounter + Range("Filelist").Row & ":F" & RowCounter + Range("Filelist").Row).Interior.ColorIndex = ProblemColour
Range("E" & RowCounter + Range("Filelist").Row).Value = "P"
Range("Filelist").Offset(RowCounter, 0).Select
Application.ScreenUpdating = True
MsgBox "Problem with file..." & Chr(13) & Chr(13) & NextFile & Chr(13) & Chr(13) & "Error=" & Err.Description, vbCritical, "Rename files"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True
End Sub
[ Jpeca @ 16.10.2019. 09:56 ] @
Ista funkcija koju imaš u ovom kodu Name može da se iskoristi i za foldere. U najjednostavnijem obliku procedura bi bila:

Code:
Sub RenameFolder(oldName, newName)

   Name oldName As newName

End Sub


Ovde nema ispitavanja da li folder postoji, da li već ima sa takvim imenom itd

Pozivanje bi bilo
Code:
Sub Test()
  RenameFolder "D:\Test", "D:\Vojvoda"
End Sub

[ vojvoda1010 @ 16.10.2019. 11:29 ] @
Ista funkcija koju imaš u ovom kodu Name može da se iskoristi i za foldere. U najjednostavnijem obliku procedura bi bila:

Code:
Sub RenameFolder(oldName, newName)

Name oldName As newName

End Sub





U gore navedenom kodu, da se samo ovo izmeni, ako sam dobro razumeo?
[ Jpeca @ 17.10.2019. 08:45 ] @
Nisam se udubljivao šta radi kod koji si postavio, dovoljno je ovo što sam napisao za Rename foldera, ako upišeš odgovarajuće vrednosti u Test proceduru. Šta dalje imaš namaru sa tim nisi naveo

Evo u prilogu imaš test primer, pa probaj
[ vojvoda1010 @ 17.10.2019. 12:00 ] @
Da pozove sve foldere i da ih preimenujem.


Vise foldera da preimenujem
[ Jpeca @ 17.10.2019. 15:25 ] @
Napraviš petlju kroz listu i za svaki par iz liste pozoveš funckiju RenameFolder sa tim parametrima.
[ vojvoda1010 @ 18.10.2019. 10:51 ] @
to je i problem
[ vojvoda1010 @ 19.10.2019. 11:06 ] @

Nesto sam uspeo,

Sub Folder_Name_To_Excel()
Dim FileSystem As Object, Folder As Object, SubFolder As Object
Dim InitialPath As String, b As Integer
b = 1
InitialPath = "C:\Users\A\Desktop\proba excel"
Set FileSystem = CreateObject("Scripting.filesystemobject")
Set Folder = FileSystem.GetFolder(InitialPath)
Range("A1").Select
For Each SubFolder In Folder.subfolders
ActiveSheet.Cells(b + 1, 1) = SubFolder
b = b + 1
Next SubFolder
End Sub


Sub RenameFolders()
Dim z As String
Dim s As String
Dim V As Integer
Dim TotalRow As Integer
TotalRow = ActiveSheet.UsedRange.Rows.Count
For V = 1 To TotalRow
z = Cells(V + 1, 1).Value
s = Cells(V + 1, 2).Value
Dim sOldPathName As String
sOldPathName = z
On Error Resume Next
Name sOldPathName As s
Next V
MsgBox "Congratulations! You have successfully renamed all the Folders"
End Sub


ali treba mi pomoc oko GetSourcePath

kako da ne nemnjam stalno InitialPath = "C:\Users\A\Desktop\proba excel", vec da mi ponudi odakle da vucem?
[ Jpeca @ 21.10.2019. 09:43 ] @
Ako želiš da koristiš sistemski dijalog da izabereš folder za GetSourcePath, preporučio bih ti da napraviš novu funkciju
Code:
Function GetFolder() As String
' Otvara dijalog za izbor foldera
' I vraca path izabranog foldera
'
Dim SelectedFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Izaberi folder "
    .ButtonName = "Confirm"
    .InitialFileName = "C:\"

    If .Show = -1 Then
        'ok clicked
        SelectedFolder = .SelectedItems(1)
    Else
        SelecteFolder = ""
    End If
End With

GetFolder = SelectedFolder

End Function


Tu funckiju sada pozoveš u tvojoj proceduri

Code:
InitialPath = GetFolder()          ' Umesto InitialPath = "C:\Users\A\Desktop\proba excel"