He realizado algunos cambios para que el código vaya más rapido:
En VBA, la selección de celdas y el uso de ActiveCell tienden a ralentizar el código, especialmente si tienes que moverte entre muchas filas. En lugar de usar Select y ActiveCell, puedes acceder directamente a los valores de las celdas mediante Cells.
Al usar MkDir, es recomendable comprobar primero si la carpeta ya existe para evitar intentos innecesarios de crear carpetas.
Evitar el uso de On Error Resume Next si es posible, esto puede ocultar otros problemas que no están relacionados con el rendimiento. Si es solo para evitar el error cuando la carpeta ya existe, es mejor usar una comprobación previa.
Sub crear_Carpetas_y_Copiar_Archivo()
Dim i As Integer
Dim Ruta As String
Dim ArchivoOrigen As String
Dim ArchivoDestino As String
Dim Cliente As String
Dim UltimaFila As Long
Ruta = "G:\Carpetas Clientes"
ArchivoOrigen = "G:\Plantillas\plantilla.xlsx" ' Ruta completa del archivo que deseas copiar
' Encuentra la última fila con datos en la columna A
UltimaFila = Cells(Rows.Count, 1).End(xlUp).Row
' Iterar desde la fila 2 hasta la última fila
For i = 2 To UltimaFila
Cliente = Cells(i, 1).Value
If Cliente <> "" Then
' Verificar si la carpeta existe antes de intentar crearla
If Dir(Ruta & "\" & Cliente, vbDirectory) = "" Then
MkDir (Ruta & "\" & Cliente) ' Crea la carpeta
End If
' Copiar el archivo solo si no existe ya en la carpeta
ArchivoDestino = Ruta & "\" & Cliente & "\plantilla.xlsx"
If Dir(ArchivoDestino) = "" Then
FileCopy ArchivoOrigen, ArchivoDestino ' Copia el archivo en la carpeta recién creada
End If
End If
Next i
MsgBox ("Se crearon las carpetas y se copiaron los archivos con éxito")
End Sub