0

Tengo el siguiente código para crear carpetas al ingresar un nuevo cliente:

    Sub crear_Carpestas()
      Dim i As Integer
      i = 0
      Ruta = "G:\Carpetas Clientes"
      Range("A2").Select
      On Error Resume Next
      Do While ActiveCell.Value <> ""
        i = i + 1
        MkDir (Ruta & "/" & ActiveCell.Value)
        ActiveCell.Offset(1, 0).Select
      Loop    
      MsgBox ("Se crearon las carpetas con Exito")
    End Sub

Pero me gustaría que al crear la carpeta también se copiara un archivo xlsx. El archivo es el mismo para cada carpeta.

Les agradecía si me pudieran ayudar, gracias.

3 respuestas 3

0

Para copiar un archivo en cada carpeta que se crea, puedes utilizar el método FileCopy de VBA, que permite copiar archivos de una ubicación a otra. A continuación te muestro cómo modificar tu macro para que, además de crear las carpetas, copie un archivo xlsx en cada una de ellas.

Sub crear_Carpetas_y_Copiar_Archivo()
    Dim i As Integer
    Dim Ruta As String
    Dim ArchivoOrigen As String
    Dim ArchivoDestino As String
    
    i = 0
    Ruta = "G:\Carpetas Clientes"
    ArchivoOrigen = "G:\Plantillas\plantilla.xlsx" ' Ruta completa del archivo que deseas copiar
    
    Range("A2").Select
    On Error Resume Next
    Do While ActiveCell.Value <> ""
        i = i + 1
        MkDir (Ruta & "\" & ActiveCell.Value) ' Crea la carpeta
        ArchivoDestino = Ruta & "\" & ActiveCell.Value & "\plantilla.xlsx" ' Ruta donde se copiará el archivo
        FileCopy ArchivoOrigen, ArchivoDestino ' Copia el archivo en la carpeta recién creada
        ActiveCell.Offset(1, 0).Select
    Loop
    
    MsgBox ("Se crearon las carpetas y se copiaron los archivos con éxito")
End Sub

Consideraciones: Ruta: Asegúrate de que la ruta especificada (G:\Carpetas Clientes) existe y está correctamente escrita. ArchivoOrigen: Asegúrate de que la ruta al archivo que deseas copiar es correcta y que el archivo existe en esa ubicación. FileCopy: Este método sobrescribirá cualquier archivo con el mismo nombre en la carpeta de destino sin advertencia.

3
  • Buenas noches compañero, quedo de maravilla de antemano muchas gracias por su colaboración. Commented el 18 sept. a las 1:17
  • Ya al agregar el archivo demora bastante,es normal o se puede mejorar? Commented el 18 sept. a las 4:17
  • El retraso en la ejecución de tu código puede deberse a varios factores, como el número de carpetas que estás creando y la velocidad de acceso a la unidad donde estás almacenando los archivos (especialmente si se trata de una unidad de red o un disco externo). Te optimizaré el código viendo otras opciones. No olvides puntuar mis soluciones, es la forma que se incentiva el trabajo voluntario en esta comunidad. :)
    – Juan
    Commented el 20 sept. a las 23:20
0

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
2
  • Muchas gracias por responder en efecto es mas rápida. Tengo otra consulta como el archivo lo tengo en una usb como hago para no estar cambiando de letra de unidad sino que sea dinamico. Que pena donde hago las puntaciones Commented el 23 sept. a las 18:54
  • Te compartiré soluciones para que la letra de la unidad sea encontrada dinamicamente. Con respecto a lo último, a la izquierda de la respuesta tienes un icono para aceptarla y también flechas hacia arriba por si deseas puntuarla. En este enlace tienes la info: es.stackoverflow.com/help/someone-answers
    – Juan
    Commented el 25 sept. a las 0:43
0

De acuerdo a lo solicitado, te comparto otra versión que busca la letra de la unidad USB dinamicamente. La macro buscará desde la unidad D: hasta la Z:. Para esta solución, se parte de la base de que el archivo plantilla.xlsx se encuentra dentro del USB en una carpeta llamada Plantillas. El nombre lo puedes cambiar en el código si es que lo guardas en otra carpeta. El cambio lo debes hacer en esta línea:

LetraUnidad = Chr(i) & ":\Plantillas\plantilla.xlsx"

Suponiendo que guardes el archivo plantilla.xlsx en la raiz del USB, te quedaría así:

LetraUnidad = Chr(i) & ":\plantilla.xlsx"

Aquí el código completo:

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
    Dim LetraUnidad As String
    Dim Encontrado As Boolean
    Dim UnidadUSB As String
    
    ' Ruta principal para las carpetas de clientes
    Ruta = "G:\Carpetas Clientes"
    
    ' Buscar la unidad USB que contiene el archivo "plantilla.xlsx"
    Encontrado = False
    For i = Asc("D") To Asc("Z") ' Itera desde la D: hasta la Z:
        LetraUnidad = Chr(i) & ":\Plantillas\plantilla.xlsx"
        If Dir(LetraUnidad) <> "" Then
            ArchivoOrigen = LetraUnidad
            UnidadUSB = Chr(i) & ":"
            Encontrado = True
            Exit For
        End If
    Next i
    
    ' Si no encuentra la unidad USB, mostrar un mensaje y salir
    If Not Encontrado Then
        MsgBox "No se encontró el archivo plantilla.xlsx en ninguna unidad USB.", vbExclamation
        Exit Sub
    End If
    
    ' 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 desde la USB
            End If
        End If
    Next i
    
    MsgBox ("Se crearon las carpetas y se copiaron los archivos con éxito desde la unidad " & UnidadUSB)
End Sub
2
  • Gracias hermano por tus mejoras de gran calidad, ahora las carpetas de clientes también están en la usb, como se hace para que también se modifique dinámicamente? Commented el 26 sept. a las 23:12
  • 1
    Ya solucione para que detente la carpeta clientes de la misma usb. De antemano muchas gracias por tus aportes para solucionar mis consultas. Commented el 27 sept. a las 1:41

Tu Respuesta

By clicking “Publica tu respuesta”, you agree to our terms of service and acknowledge you have read our privacy policy.

¿No es la respuesta que buscas? Examina otras preguntas con la etiqueta o formula tu propia pregunta.