Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Dr.Windows
Moderator
Moderator
Mesaje: 4570
Membru din: Vin Iul 31, 2009 7:32 am

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de Dr.Windows » Joi Sep 27, 2018 8:44 pm

Presupunand urmatoarele:
1. in fisierul atasat de tine celula A1 contine un "prefix" si este scris doar acolo,
2. in C1 ai un "sufix" si apare o singura data
3. pe coloana B ai scris numele folderelor ce ar trebui create
4. pe coloana G ai datele calendaristice pentru care trebuie create subfoldere

adaugand suplimentar, cel putin pentru testele pe care le-am facut un folder "Radacina" care trebuie sa existe ca subfolder acolo unde vei pune fisierul cu codul atasat, ar trebui ca urmatorul cod sa faca treaba cu o conditie suplimentara - NU trebuie sa existe caractere invalide sau mai exact nepermise in denumirea unui folder, pentru ca acest cod nu face verificari suplimentare.

Asa ca testeaza codul de mai jos:

Cod: Selectaţi tot

Sub CreareFoldere()
    Dim Prefix As String, NumeFolder As String, Sufix As String
    Dim cFolder As String, cData As String
    Dim nFolder As Double, nData As Double
    Dim Cale As String
    
    'seteaza parametrii initiali
    Cale = ThisWorkbook.Path & "\Radacina\"
    Prefix = Range("A1").Value
    Sufix = Range("C1").Value
    cFolder = "B"   'Coloana de unde citeste folderele
    cData = "G"     'Coloana de unde citeste datele - trebuie sa contina date calendaristice nu text
    
    'Detecteaza cate randuri sunt de parcurs pe coloanele cFolder si cData
    nFolder = ActiveSheet.Cells(ActiveSheet.Rows.Count, cFolder).End(xlUp).Row
    nData = ActiveSheet.Cells(ActiveSheet.Rows.Count, cData).End(xlUp).Row
    
    'Creeaza folderele
    For i = 1 To nFolder
        NumeFolder = Prefix & Range(cFolder & i).Value & Sufix
        MkDir (Cale & NumeFolder)
        For j = 1 To nData
            MkDir (Cale & NumeFolder & "\" & Format(Range(cData & j).Value, "dd-mm-yyyy"))
        Next j
    Next i
End Sub
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

gh19612005
Mesaje: 205
Membru din: Lun Dec 28, 2009 6:10 pm
Localitate: Pitesti

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de gh19612005 » Joi Sep 27, 2018 9:56 pm

Functioneaza perfec!
Ca sa pregatesc fisierul si apoi sa rulez codul, mi-a trebuit cam un minut.
Vechea medoda de lucru mi-ar fi luat cam 40-50 de minute!
Multumesc din suflet!!!
G.H.

gh19612005
Mesaje: 205
Membru din: Lun Dec 28, 2009 6:10 pm
Localitate: Pitesti

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de gh19612005 » Vin Sep 28, 2018 10:23 am

Mi-am permis sa fac mici modificari in cod, cea mai importanta fiind afisarea datei din numele subfolderelor sub forma "yyyy.mm.dd". (fisierul atasat)
Si pentru ca am ajuns in acest punct, eu, ca un adevarat "tigan" (asa e vorba romaneasca, departe de mine gandul rau despre aceasta etnie), vin cu alta provocare:
am foarte multe fisiere care au numele de forma "dd.mm.yyyy"&"string n".extensie unde "string n" sunt diverse expresii, gen "confirmare"; "NIR"; "Aviz de expeditie"; "# numere comenzi"...deci vreau sa subliniez ca aceste expresii nu se supun nici unei reguli :(.
Aceste fisiere se sorteaza intai in ordine crescatoare a zilei, apoi a lunii si dupa aceea a anului, rezultand alaturarea unor fisiere din luni si chiar ani diferiti.
Provocarea este de a gasi o metoda de redenumire in bloc a acestor fisiere in forma "yyyy.mm.dd"&"string n", pentru a se sorta ele implicit in ordinea fireasca.

Cod: Selectaţi tot

Sub CreareFoldere()
    Dim Prefix As String, NumeFolder As String, Sufix As String, Prefix2 As String
    Dim cFolder As String, cData As String
    Dim nFolder As Double, nData As Double
    Dim Cale As String
    
    'seteaza parametrii initiali
    Cale = ThisWorkbook.Path & "\Radacina\"
    Prefix = Range("A1").Value
    Prefix2 = Range("F1").Value
    Sufix = Range("C1").Value
    cFolder = "B"   'Coloana de unde citeste folderele
    cData = "G"     'Coloana de unde citeste datele - trebuie sa contina date calendaristice nu text
    
    'Detecteaza cate randuri sunt de parcurs pe coloanele cFolder si cData
    nFolder = ActiveSheet.Cells(ActiveSheet.Rows.Count, cFolder).End(xlUp).Row
    nData = ActiveSheet.Cells(ActiveSheet.Rows.Count, cData).End(xlUp).Row
    
    'Creeaza folderele
    For i = 1 To nFolder
        NumeFolder = Prefix & Range(cFolder & i).Value & Sufix
        MkDir (Cale & NumeFolder)
        For j = 1 To nData
            MkDir (Cale & NumeFolder & "\" & Prefix2 & Format(Range(cData & j).Value, "yyyy.mm.dd"))
        Next j
    Next i
End Sub
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
G.H.

Dr.Windows
Moderator
Moderator
Mesaje: 4570
Membru din: Vin Iul 31, 2009 7:32 am

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de Dr.Windows » Vin Sep 28, 2018 7:02 pm

gh19612005 scrie:
Joi Sep 27, 2018 9:56 pm
Multumesc din suflet!!!
Cu placere. :D
gh19612005 scrie:
Vin Sep 28, 2018 10:23 am
...vin cu alta provocare:
am foarte multe fisiere care au numele de forma "dd.mm.yyyy"&"string n".extensie unde "string n" sunt diverse expresii, gen "confirmare"; "NIR"; "Aviz de expeditie"; "# numere comenzi"...deci vreau sa subliniez ca aceste expresii nu se supun nici unei reguli :(.
Conteaza numai daca primele 10 caractere reprezinta peste tot data. Ar fi o regula "suficienta" pentru a putea corecta numele.
Deci toate incep de forma "DD.MM.YYYYAAAAAAAAAAAA...."? (unde AAA... reprezinta orice alt caracter alfanumeric)

gh19612005
Mesaje: 205
Membru din: Lun Dec 28, 2009 6:10 pm
Localitate: Pitesti

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de gh19612005 » Vin Sep 28, 2018 8:17 pm

Dr.Windows scrie:
Vin Sep 28, 2018 7:02 pm

Conteaza numai daca primele 10 caractere reprezinta peste tot data. Ar fi o regula "suficienta" pentru a putea corecta numele.
Deci toate incep de forma "DD.MM.YYYYAAAAAAAAAAAA...."? (unde AAA... reprezinta orice alt caracter alfanumeric)
Da!
G.H.

Dr.Windows
Moderator
Moderator
Mesaje: 4570
Membru din: Vin Iul 31, 2009 7:32 am

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de Dr.Windows » Sâm Sep 29, 2018 11:06 am

Atunci problema este simpla - doar se extrag primele 10 caractere si se schimba ordinea lor:

Cod: Selectaţi tot

Sub RedenumireFisiere()
    Dim Cale As String, NumeFisier As String, NumeNou As String
    
    Cale = "D:\Temp\Test\Rename\"
    NumeFisier = Dir(Cale & "*.*")
    Do While NumeFisier <> ""
        Prefix = Mid(NumeFisier, 1, 10) 'Extrage primele 10 caractere unde ar trebui sa fie data
        If InStrRegEx(Prefix, "([0-9]{2}).([0-9]{2}.([0-9]{4}))") = 1 Then  'se asigura ca sirul extras respecta regula NN.NN.NNNN
            NumeNou = Mid(NumeFisier, 7, 4) & "." & Mid(NumeFisier, 4, 2) & "." & Mid(NumeFisier, 1, 2) & Mid(NumeFisier, 11)   'Recompune noul nume
            Name Cale & NumeFisier As Cale & NumeNou
        End If
        NumeFisier = Dir()
    Loop
End Sub
Pentru a ma asigura ca primele 10 caractere respecta regula "NN.NN.NNNN" unde N inseamna o valoare numerica am folosit o functie suplimentara ce are nevoie de activarea unei referinte in meniul editorului VBA/Tools/References/Microsoft VBScript Regular Expressions 5.5:
Referinte.png

Cod: Selectaţi tot

Public Function InStrRegEx(ByVal searchIn As String, ByVal searchFor As String) As Long
    'REQUIREMENT: Reference - Microsoft VBScript Regular Expressions 5.5
    Dim regEx As Object, found As Object
    If Len(searchIn) > 0 And Len(searchFor) > 0 Then
        Set regEx = CreateObject("VBScript.RegExp")
        regEx.Pattern = searchFor
        regEx.Global = True
        regEx.IgnoreCase = True
        Set found = regEx.Execute(searchIn)
        If found.Count <> 0 Then InStrRegEx = found(0).FirstIndex + 1
    End If
End Function
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

gh19612005
Mesaje: 205
Membru din: Lun Dec 28, 2009 6:10 pm
Localitate: Pitesti

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de gh19612005 » Dum Sep 30, 2018 11:54 am

Functioneaza perfect!

I-am setat o cale in C:
am activat referinta aceea
am pus si un buton...
am copiat in folderol "Cale" cam 300 de fisiere
am rulat codul...succes!
am observant ca doua fisiere nu aveau in denumire decat "dd.mm"&string
le-am completat manual anul si am rulat din nou codul

Succes deplin!!!
Multumirile de mai sus le reinnoiesc insutit!
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.
G.H.

Dr.Windows
Moderator
Moderator
Mesaje: 4570
Membru din: Vin Iul 31, 2009 7:32 am

Re: Creare si/sau redenumire foldere si/sau fisiere "colectiv", dupa un criteriu

Mesaj de Dr.Windows » Dum Sep 30, 2018 4:31 pm

gh19612005 scrie:
Dum Sep 30, 2018 11:54 am
am observant ca doua fisiere nu aveau in denumire decat "dd.mm"&string
Din acest motiv se face verificarea sa respecte formatul NN.NN.NNNN pentru ca pot exista exceptii, pe care va trebui sa le rezolvi "manual",
gh19612005 scrie:
Dum Sep 30, 2018 11:54 am
Multumirile de mai sus le reinnoiesc insutit!
Cu placere! :D

Scrie răspuns

Înapoi la “Visual Basic for Application (VBA) cu Excel - Intrebari tehnice”