Group files based on similar names within various sub folders

[zelarra]

Hi guys.

I'm looking for a way to improve a code I made to classify files with similar names into folders.

The code I'm commenting on is as follows:

Option Explicit

Public Sub IniciarClasificar()

    Clasificar

    Borrar
    
    MsgBox "Se ha completado correctamente la tarea de clasificar los archivos en carpetas.", vbInformation, "Eventos masivos"
    
    Application.GoTo Hoja1.Range("A1"), True

End Sub

Private Sub Clasificar()

    Dim Celda               As Range
    Dim NombreArchivo       As String
    Dim NombreCarpeta       As String
    Dim fso                 As Object
    Dim RutaOrigen          As String
    Dim RutaDestino         As String
    
    On Error Resume Next
    
    For Each Celda In Hoja1.Range("A1").CurrentRegion.Cells

        RutaOrigen = Celda.Value
        
        NombreArchivo = Right(Celda.Value, Len(Celda.Value) - InStrRev(Celda.Value, "\")) 'Nombre del archivo
        
        If Len(NombreArchivo) - Len(Replace(NombreArchivo, "_", "")) = 0 Then
        
            NombreCarpeta = "Varios"
              
        Else
        
            If Left(NombreArchivo, 1) = "_" Then
            
                NombreCarpeta = Split(NombreArchivo, "_")(1)

            ElseIf Left(NombreArchivo, 3) = "IMG" Or Left(NombreArchivo, 3) = "VID" Then
                
                NombreCarpeta = Split(NombreArchivo, "_")(1)

            ElseIf Left(NombreArchivo, 1) <> "_" Then
            
                NombreCarpeta = Split(NombreArchivo, "_")(0)
                                
            End If
            
        End If

        RutaDestino = Replace(RutaOrigen, NombreArchivo, "") & NombreCarpeta
    
        If Dir(RutaDestino, vbDirectory) = "" Then
    
            Set fso = CreateObject("Scripting.FileSystemObject")

            fso.CreateFolder RutaDestino

            Set fso = Nothing
    
        End If
    
        RutaDestino = RutaDestino & "\" & NombreArchivo
        
        FileCopy RutaOrigen, RutaDestino
        Kill RutaOrigen

    Next Celda
               
End Sub

Private Sub Borrar()
    
    Hoja1.Range("A:A").ClearContents
    
End Sub

Broadly speaking, I distinguish four types:

- If it is a video (because VID is in the name)

- If it is an image (because IMG is in the name)

- If it has "_".

- If it is none of the above, it is put in a junk drawer.

My problem comes with "_" and, by extension, with the others (if you notice, VID and IMG also have "_").

I would like to get it to organize the files by similar names, without having to take any reference (VID, IMG or _).

Here I copy a list of file names for you to use as an example.

accionpoeticafrases_20240126_p_3288885058160057668_1_3288885058160057668.jpg
accionpoeticafrases_20240129_p_3291197434721271638_1_3291197434721271638.jpg
adelapordiosxd_20231101_p_3226479731074067045_1_3226479720361666220.jpg
adictosdelhumor_20240309_p_3319580724477181957_1_3319580724477181957.jpg
buitrago.monologos_20240430_p_3357800092432231595_1_3357800092432231595.jpg
club_deletras_20231001_p_3203563422477877505_1_3203563422477877505.jpg
club_deletras_20231006_p_3207871459997585273_1_3207871459997585273.jpg
club_deletras_20231014_p_3213024703165492340_1_3213024703165492340.jpg
IMG_20240629_134052.jpg
PANO_20240629_134109.jpg
PANO_20240629_134117.jpg
VID_20220629_105434.mp4
VID_20230629_134058.mp4
VID_20240629_105434.mp4
VID_20240329_134058.mp4
VID_20240629_134058.mp4

Thank you very much.

 

[zelarra]

Hi guys.

Is there anyone who can help me with this?

Thanks.

 

[Sektor]

So, you want create folder for each value between "_"?

 

[zelarra]

I would like to get it to organize the files by similar names, without having to take any reference (VID, IMG or _).

 

[Sektor]

Not clear... Could you show (on your example list) what and where should go? Thanks.

 

[zelarra]

Let's try it.

In my first post, I shared the code I'm using right now.

I attach in this table, taking as an example the file names I mentioned in the first post, what I get with my code and what I would like to get, marking with colors what I already get and what I don't get yet.

 

[Fuji]

try

Sub test()
    Dim r As Range
    With CreateObject("VBScript.RegExp")
        .Pattern = "^(([a-z].+?)_\d{8}_.*|[A-Z].*?_(\d{4})(\d{2})(\d{2})_.*)$"
        For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
            If .test(r) Then r(, 2) = .Replace(r, "$2$3.$4.$5")
        Next
    End With
End Sub

 

[zelarra]

Hello.

Thank you very much, it works quite well, although there are some names that it doesn't pick up correctly.

I am attaching an Excel with about 1500 names to which I have passed the code that you suggest, so that you can see that there are names that it doesn't pick up and I don't understand why.

Again: thank you very much.

Dropbox

www.dropbox.com

 

[zelarra]

Dropbox

www.dropbox.com

 

[Fuji]

OK. I need to see your desired results as well.