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ść
caelian
Stały bywalec Excelforum


Wersja: Win Office 365
Pomógł: 51 razy
Posty: 484

Wysłany: 18-02-2021, 09:50   makro do zmiany nazwy plików w folderze.

CZeść

Gorąca prośba o pomoc:)

mam do ściągniecia w pracy ogromna liczbę plików.
Zmiana nazwy kazdego pliku to bedzie robota manualna i ciężka.

Prosiłbym o napisanie makra które wchodzi do wskazanego folderu.
Otwiera po kolei każdy plik.
Z komórki I6 pobiera nazwę i zmienia nazwę aktualnie otwartego pliku na tę pobraną z tej komórki.

Będę wdzięczny za pomoc.
ID posta: 400600 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 18-02-2021, 10:01   

Mając już tyle postów i udanych odpowiedzi powinieneś czasami użyć szukajki na naszym forum i zapewne coś znajdziesz.
Ten temat był już poruszany.
_________________
Pozdrawiam.
ID posta: 400601 Skopiuj do schowka
 
 
caelian
Stały bywalec Excelforum


Wersja: Win Office 365
Pomógł: 51 razy
Posty: 484

Wysłany: 18-02-2021, 10:17   

Szukałem po interesujących mnie frazach.
"zmiana nazwy pliku w folderze po nazwie z komórki"
"zmiana nazwy pliku"
"nazwa pliku wg danej z kolumny"
"masowa zmiana nazw plików wg danej z komórki"

zaden z tematow postow jakie znalazlem nie był tym czego szukałem
ID posta: 400602 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 18-02-2021, 11:01   

A zapytanie takie.
Szukaj wszystkich słów - "Zmiana nazwy plików".
W opcjach - Przeszukaj tylko tytuł wiadomości
_________________
Pozdrawiam.
ID posta: 400605 Skopiuj do schowka
 
 
caelian
Stały bywalec Excelforum


Wersja: Win Office 365
Pomógł: 51 razy
Posty: 484

Wysłany: 18-02-2021, 11:27   

znajduje mój temat, a potem na kolejnych 4 stronach są różne termaty ale nie to czego szukam.
są odwolania, wyciganie formula czesci nazwy pliku, kolorawnie komórek...
ID posta: 400607 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 18-02-2021, 12:43   

Nie wiem jak nazwać to szukanie u Ciebie..., ale spójrz, co można znaleźć jak się chce.
_________________
Pozdrawiam.
ID posta: 400614 Skopiuj do schowka
 
 
caelian
Stały bywalec Excelforum


Wersja: Win Office 365
Pomógł: 51 razy
Posty: 484

Wysłany: 18-02-2021, 13:16   

dopisałem do tamtego wątku wymaganą przezemnie modyfikację.

ten temat odnosi się tylko do zmiany nazwy plików w folderze.
ID posta: 400623 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 18-02-2021, 16:53   

Znasz nazwę arkusza (czy jest stała we wszystkich plikach) z komórką 'I6'.
Bardziej by uprościło zamianę nazwy bez otwierania plików.
_________________
Pozdrawiam.
ID posta: 400636 Skopiuj do schowka
 
 
caelian
Stały bywalec Excelforum


Wersja: Win Office 365
Pomógł: 51 razy
Posty: 484

Wysłany: 18-02-2021, 17:01   

tak,
ściągany plik ma zawsze tylko 1 arkusz "Sheet1" (pracuje na angielskim excelu)

jak nie trzeba otwierać totym lepiej :)
ID posta: 400638 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 18-02-2021, 21:14   

Przetestuj moją propozycję wykorzystującą rozwiązanie podane przez @Patronus oraz funkcję Application.ExecuteExcel4Macro do pobrania danych z zamkniętego skoroszytu.
W kodzie musisz zmienić ścieżkę dostępu do folderu z plikami na własną.
Kod:
Sub Zmiana_Nazwy_Skoroszytu()
    Dim objFSO As Object, folder As Object, pliki As Object, p As Object
    Dim pos As Integer
    Dim wbpath As String, celref As String, wsnm As String, oldsh As String, newsh As String, _
                oldWbnm As String, newWbnm As String
   
    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
    For Each p In pliki
        oldsh = folder & "\" & p.Name
        newWbnm = Application.ExecuteExcel4Macro("'" & wbpath & "[" & p.Name & "]" & wsnm & "'!" & Range(celref).Address(True, True, -4150))
        pos = InStr(1, p.Name, ".")
        oldWbnm = Left(p.Name, pos - 1)
        newsh = folder & "\" & Replace(p.Name, oldWbnm, newWbnm)
        objFSO.movefile oldsh, newsh
    Next
End Sub
_________________
Pozdrawiam.
ID posta: 400652 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3100 razy
Posty: 10274
Wysłany: 18-02-2021, 23:58   

caelian napisał/a:
dopisałem do tamtego wątku wymaganą przezemnie modyfikację.
I nigdy więcej tego nie rób! Tamten wątek, choć może wydawać się podobny, dotyczy czego innego. Takim działaniem robisz bałagan na forum.

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 400656 Skopiuj do schowka
 
 
caelian
Stały bywalec Excelforum


Wersja: Win Office 365
Pomógł: 51 razy
Posty: 484

Wysłany: 19-02-2021, 09:06   

no to mam sprzeczne informację.
wg kuma, miałem poszukać innego wątku tematu i zrozumiałem to że mam znaleść i moje pytania zadać tam.

Z samego początku jak widać próbowałem znaleźć to czego suzkam bez rezultatu.

@kuma dzieki za kod, zaraz go potestuje

//EDIT
wynik testu:
nie do konca działa, o ile w pętli parametr P zmienia ściężkę do pliku prawidłowo, tak parametr:

Kod:
newWbnm

otwiera okno dostepowe do pliku i chce inicjować iu zmieniać nazwę pliku desktop.ini

może dasz radę to zmodyfikować tak aby działał na plikach z rozszerzeniem .xlsx a inne pomijał?

aha i jeszcze jedno: moja ścieżka to:
C:\Users\<username>\Downloads
z racji że to firmowy laptop to usunąłem nazwę usera.
ID posta: 400666 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1447 razy
Posty: 4129
Wysłany: 19-02-2021, 11:22   

U mnie działa prawidłowo. Może masz niewłaściwe parametry funkcji 'Application.ExecuteExcel4Macro()'.
Poprawiłem, aby "reagował tylko" na pliki z rozszerzeniem .xlsx.
Kod:
Sub Zmiana_Nazwy_Skoroszytu()
    Dim objFSO As Object, folder As Object, pliki As Object, p As Object
    Dim pos As Integer
    Dim wbpath As String, celref As String, wsnm As String, oldsh As String, newsh As String, _
                oldWbnm As String, newWbnm As String
   
    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
    For Each p In pliki
        oldsh = folder & "\" & p.Name
        If oldsh Like "*.xlsx" Then
            newWbnm = Application.ExecuteExcel4Macro("'" & wbpath & "[" & p.Name & "]" & wsnm & "'!" & Range(celref).Address(True, True, -4150))
            pos = InStr(1, p.Name, ".")
            oldWbnm = Left(p.Name, pos - 1)
            newsh = folder & "\" & Replace(p.Name, oldWbnm, newWbnm)
            objFSO.movefile oldsh, newsh
        End If
    Next
End Sub
_________________
Pozdrawiam.
ID posta: 400671 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2498 razy
Posty: 8314
Wysłany: 19-02-2021, 12:06   

Mi wyszło tak:
Kod:
Option Explicit

Sub test()
Const sPath As String = "C:\Users\mkkk2\Downloads\"    'Dopasuj ścieżkę
Const sSheet As String = "Sheet1"
Const sRef As String = "I6"
Dim sFile As String
Dim sName As String
Dim i As Long
Dim vArr As Variant
Dim Tmp As Variant


Call ListFiles(sPath, vArr, "*.xlsx", False)   'Tu dopasuj sobie parametry funkcji

    If IsEmpty(vArr) Then
        MsgBox "Nie znaleziono plików o danych kryteriach.", vbInformation
        Exit Sub
    End If

    For i = 1 To UBound(vArr)
        Tmp = Split(vArr(i), Application.PathSeparator)
        sFile = Tmp(UBound(Tmp))
        sName = ADOGetValue(sPath, sFile, sSheet, sRef)(1, 1)
        If Name_Is(sName) Then
            Name vArr(i) As sPath & sName & ".xlsx"
        Else
            Debug.Print vArr(i) & " | " & sName
        End If
    Next i


End Sub

Sub ListFiles(ByVal sFolder As String, ByRef varrFiles As Variant, _
              Optional sFilter As String, Optional vSubFolders As Variant)

'---------------------------------------------------------------------------------------
' Procedure : ListFiles
' DateTime  : 08.12.2013
' Author  : Artik
' Purpose   : Procedura listująca nazwy plików (pełne odwołanie) we wskazananym folderze.
'       Procedura działa rekurencyjnie.
'
' sFolder -   obowiązkowy; wskazany folder
' varrFiles - obowiązkowy; zmienna typu Variant,
'       do której zostanie przekazana tablica znalezionych plików
' sFilter -   opcjonalny; wzorzec wg którego poszukiwane są pliki
'       jl. nie podano - wszystkie pliki
'       Przykłady wzorca: "*.xls*" - pliki Excela
'                 "*Q#*.xls*" - pliki Excela, zawierające w nazwie numer kwartału
'                 "Raport*.*" - wszystkie pliki, których nazwa rozpoczyna się
'                       od Raport...
'                 "[!~]*.xls*" - pliki Excela, bez plików tymczasowych
' vSubFolders - opcjonalny;
'         jl. nie podano - a folder zawiera podfoldery, pojawi się pytanie
'                czy uwzględnić w poszukiwaniach podfoldery
'         True - gdy są podfodery, bezwzględnie je przeszukaj
'         False - gdy są podfoldery, bezwzględnie ich NIE przeszukuj
'---------------------------------------------------------------------------------------
'

Dim FSO As Object  'Scripting.FileSystemObject
Dim fsoFolder As Object  'Scripting.Folder
Dim fsoSubFolders As Object  'Scripting.Folders
Dim fsoSubFolder As Object  'Scripting.Folder
Dim fsoFile As Object  'Scripting.File
Dim i As Long


    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.FolderExists(sFolder) Then
        Set fsoFolder = FSO.GetFolder(sFolder)
        Set fsoSubFolders = fsoFolder.Subfolders
        On Error Resume Next
        If fsoSubFolders.Count > 0 Then

            If IsMissing(vSubFolders) Then
                If MsgBox("Czy uwzględnić podfoldery?", _
                          vbQuestion + vbYesNo, _
                          "Lista plików") = vbYes Then
                    vSubFolders = True
                Else
                    vSubFolders = False
                End If
            End If

        Else
            vSubFolders = False

        End If    'fsoSubFolders.Count > 0


        If Len(sFilter) = 0 Then sFilter = "*.*"


        For Each fsoFile In fsoFolder.Files
            Application.StatusBar = "Przeszukiwanie folderu: " & fsoFolder.path

            If UCase(fsoFile.Name) Like UCase(sFilter) Then
                If IsEmpty(varrFiles) Then
                    ReDim varrFiles(1 To 1)
                End If

                i = UBound(varrFiles)

                If IsEmpty(varrFiles(i)) Then
                    i = i - 1
                End If

                i = i + 1

                ReDim Preserve varrFiles(1 To i)

                varrFiles(i) = fsoFile.path    'pełne odwołanie
                'varrFiles(i) = fsoFile.Name 'tylko nazwa pliku z rozszerzeniem

            End If    'UCase(fsoFile.Name) Like UCase(sFilter)

        Next fsoFile


        If vSubFolders Then
            For Each fsoSubFolder In fsoSubFolders
                Call ListFiles(fsoSubFolder.path, varrFiles, sFilter, True)
            Next fsoSubFolder
        End If    'vSubFolders = True

    End If  'FSO.FolderExists(sFolder) = True

    Set fsoSubFolders = Nothing
    Set fsoFolder = Nothing
    Set FSO = Nothing

    Application.StatusBar = False
    On Error GoTo 0
End Sub


Function Name_Is(sStr As String) As Boolean
Dim el As Variant
    If VBA.Len(sStr) = 0 Then Exit Function
    For Each el In Array("<", ">", ":", """", "/", "\", "|", "?", "*")
        If UBound(VBA.Split(sStr, el)) > 0 Then Exit Function
    Next el
    Name_Is = True
End Function


'http://www.excelforum.pl/topics3/funkcja-getvalue-vt12354.htm?postdays=0&postorder=asc&highlight=%2Aadogetvalue%2A&start=0
Function ADOGetValue(path As String, file As String, sheet As String, ref As String)
' =ADOGetValue(p;f;s;r)
' p - scieżka
' f - nazwa pliku
' s - nazwa arkusza
' r - komórka lub obszar np. "A3", "A1:A10"
Dim arg As String
Dim nRowCount As Long, nColCount As Long
Dim nActRow As Long, nActCol As Long
Dim ArrVal() As Variant
Dim xArray As Variant
Dim xValue As Variant
Dim strConnectionString As String
Dim oCn As Object, oRs As Object



    On Error GoTo ADOGetValue_Error

    If Right(path, 1) <> "\" Then path = path & "\"

    If Dir(path & file) = "" Then
        'brak pliku ...
        ADOGetValue = CVErr(2042)
        Exit Function
    End If

    Set oCn = CreateObject("ADODB.Connection")

    If Val(Application.Version) < 12 Then
        strConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                              "Data Source=" & path & file & ";" & _
                              "Extended Properties=""Excel 8.0;HDR=NO;IMEX=1;"""
    Else
        strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & path & file & ";" & _
                              "Extended Properties=""Excel 12.0;HDR=NO;IMEX=1;"""
    End If
    oCn.Open strConnectionString
    arg = "select * from [" & sheet & "$" & ref & _
          IIf(InStr(ref, ":") = 0, ":" & ref, "") & "]"

    Set oRs = CreateObject("ADODB.Recordset")

    oRs.Open arg, oCn, 3

    xArray = oRs.getRows

    nRowCount = UBound(xArray, 2)
    nColCount = UBound(xArray, 1)

    ReDim ArrVal(1 To nRowCount + 1, 1 To nColCount + 1)

    For nActRow = 0 To nRowCount

        For nActCol = 0 To nColCount

            xValue = xArray(nActCol, nActRow)

            If IsNumeric(xValue) Then
                xValue = CDbl(xValue)
            ElseIf IsNull(xValue) Then
                xValue = Empty
            End If

            ArrVal(nActRow + 1, nActCol + 1) = xValue

        Next

    Next

    ADOGetValue = ArrVal

    oRs.Close
    oCn.Close

    Set oRs = Nothing
    Set oCn = Nothing



    On Error GoTo 0
    Exit Function

ADOGetValue_Error:
    ReDim ArrVal(1 To 1, 1 To 1)
    ArrVal(1, 1) = vbNullString
    ADOGetValue = ArrVal
End Function
W oknie Immediate będziesz miał wylistowane pliki, które w komórce I6 posiadają znaki niedozwolone dla nazw plików.
Dopasuj ścieżkę i parametry dla funkcji ListFiles
Testuj.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 400673 Skopiuj do schowka
 
 
caelian
Stały bywalec Excelforum


Wersja: Win Office 365
Pomógł: 51 razy
Posty: 484

Wysłany: 19-02-2021, 14:07   

Dziekuję
teraz działa

jednak potrzebowałbym jeszczę weryfikację
wywala się w momencie jesli nowa nazwa pliku istnieje już w folderze.

W takim wypadku chciałbym aby wszedł do pliku który już istnieje, zweryfikował czy ma prawidłoa nazwę, jesli tak to niech dopisze " - Original" & Counter

Counter jako zmienna liczbowa.

jesli nie, to ma podmienic nazwę dubla na prawidłową.
ID posta: 400685 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