Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: Artik
18-02-2021, 23:13
makro do zmiany nazwy plików w folderze.
Autor Wiadomość
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1443 razy
Posty: 4113
Wysłany: 19-02-2021, 19:56   

Jeśli Twoja ostatnia odpowiedź dotyczy mojego rozwiązania to wykorzystałbym Dictionary, ale dopiero po weekendzie. Teraz czas relaksu. :lol:
_________________
Pozdrawiam.
ID posta: 400717 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1443 razy
Posty: 4113
Wysłany: 22-02-2021, 08:37   

Przetestuj coś takiego. Procedura jest "odporna' na powtórne uruchomienie już wcześniej zrobionej podmiany nazw.
Kod:
Dim d As Object
Sub Zmiana_Nazw_kuma()
    Dim objFSO As Object, folder As Object, pliki As Object, p As Object
    Dim wbpath As String, celref As String, wsnm As String, oldWb As String, newWb As String, _
                oldWbnm As String, newWbnm As String
   '        d.items     d.keys
    Set objFSO = CreateObject("scripting.filesystemobject")
    wbpath = "c:\Users\User\Downloads\Temp1\"           'tutaj podaj swoją ścieżkę do plików
    celref = "I6": wsnm = "Sheet1"
   
    Set folder = objFSO.GetFolder(wbpath)
    Set pliki = folder.Files
    Set d = VBA.CreateObject("Scripting.Dictionary")
    For Each p In pliki
        oldWbnm = Left(p.Name, InStr(1, p.Name, ".") - 1)
        d(oldWbnm) = Empty
    Next
    For Each p In pliki
        oldWb = folder & "\" & p.Name
        If oldWb Like "*.xlsx" Then
       
            oldWbnm = Left(p.Name, InStr(1, p.Name, ".") - 1)
            d(oldWbnm) = Empty
            newWbnm = Application.ExecuteExcel4Macro("'" & wbpath & "[" & p.Name & "]" & wsnm & "'!" & _
                                Range(celref).Address(True, True, -4150))
            newWbnm = NewName(newWbnm)
           
            If Not d.exists(newWbnm) Then
                newWb = folder & "\" & Replace(p.Name, oldWbnm, newWbnm)
                objFSO.movefile oldWb, newWb
            End If
        End If
    Next
    Set d = Nothing
End Sub

Private Function NewName(ms As String) As String
    If Not d.exists(ms) Then
        d(ms) = 1
    Else
        d.Item(ms) = d.Item(ms) + 1
    End If
    NewName = ms & "_" & d.Item(ms)
End Function
_________________
Pozdrawiam.
ID posta: 400823 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe