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]

Ok, thanks a lot.