Macro para importar datos de varios archivos en una misma carpeta

Importar datos de varias hojas pero en la hoja resumen hay alguna columna que pierde el formato al importar por ejemplo columnas con fechas y seria posible también el copiar el encabezado del primer archivo ya que todos los archivos son iguales

1 Respuesta

Respuesta
2

Debes ser más específico con los ejemplos y con la información.

Nombres de archivos, de carpetas, de hojas, cuáles columnas y filas copiar, en dónde las quieres pegar, etc, etc.

Uso uno de tus archivos para importar datos de varias hojas pero en la hoja resumen hay alguna columna que pierde el formato al importar por ejemplo columnas con fechas y seria posible también el copiar el encabezado del primer archivo ya que todos los archivos son iguales

Sub Importar_Datos()
'
'    Por.Dante Amor
'
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Valores")
    Set h2 = l1.Sheets("Resumen")
    h2.Cells.ClearContents
    '
    ruta = h1.[B5]
    hoja = h1.[B6]
    fila = h1.[B7]
    colu = h1.[B8]
    '
    mensaje = validaciones(ruta, hoja, fila, colu)
    If mensaje <> "" Then
        MsgBox mensaje, vbExclamation, "IMPORTAR ARCHIVOS"
        Exit Sub
    End If
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    Application.Calculation = xlCalculationManual
    '
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    arch = Dir(ruta & ".xls")
    i = 0
    Do While arch <> ""
        i = i + 1
        Application.StatusBar = "Importando Libro : " & i & " de : " & n
        Set l2 = Workbooks.Open(ruta & arch)
        existe = False
        If IsNumeric(hoja) Then
            If l2.Sheets.Count >= hoja Then
                existe = True
                Set h22 = l2.Sheets(hoja)
            Else
            End If
        Else
            For Each h In l2.Sheets
                If LCase(h.Name) = LCase(hoja) Then
                    existe = True
                    Set h22 = l2.Sheets(hoja)
                    Exit For
                End If
            Next
        End If
        '
        If existe Then
            u22 = h22.Range(colu & Rows.Count).End(xlUp).Row
            u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
            h22.Rows(fila & ":" & u22).Copy
            h2.Range("A" & u2).PasteSpecial xlValues
        End If
        '
        l2.Close False
        arch = Dir()
    Loop
    '
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    '
    MsgBox "Proceso terminado, archivos importados a la hoja resumen", vbInformation, "IMPORTAR ARCHIVOS"
End Sub
'
Function validaciones(ruta, hoja, fila, colu)
    validaciones = ""
    If ruta = "" Then
        validaciones = "Escribe la Carpeta donde están los archivos"
        Exit Function
    End If
    If Dir(ruta, vbDirectory) = "" Then
        validaciones = "No existe la Carpeta"
        Exit Function
    End If
    If hoja = "" Then
        validaciones = "Escribe el nombre o número de hoja"
        Exit Function
    End If
    If fila = "" Or Not IsNumeric(fila) Or fila < 1 Then
        validaciones = "Escribe la fila inicial"
        Exit Function
    End If
    If colu = "" Or IsNumeric(colu) Then
        validaciones = "Escribe la columna principal"
        Exit Function
    End If
    '
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    arch = Dir(ruta & ".xls")
    n = 0
    Do While arch <> ""
        n = n + 1
        arch = Dir()
    Loop
    If n = 0 Then
        validaciones = "No hay archivos de excel a importar en la carpeta : " & ruta
        Exit Function
    End If
End Function

"Hay alguna columna que pierde el formato"

Puedes ser más específico, recuerda, yo no estoy viendo tu hoja de excel.

Entonces escribe cuáles columnas están perdiendo el formato.


"Copiar el encabezado del primer archivo "

Debes ser bien específica en cada una de tus peticiones, en cuál fila está el encabezado

este es el archivo

Esa imagen no responde mis dudas:

"Hay alguna columna que pierde el formato"

Puedes ser más específico, recuerda, yo no estoy viendo tu hoja de excel.

Entonces escribe cuáles columnas están perdiendo el formato.


"Copiar el encabezado del primer archivo "

Debes ser bien específica en cada una de tus peticiones, en cuál fila está el encabezado


Ayúdame a ayudarte, si no pones la información completa, es difícil entender qué necesitas.

Si es complicado explicar, envíame tu archivo con los ejemplos.

mi correo: [email protected]

Los datos con formatos de fecha están en la columna B y el encabezado de los datos esta en la línea A1 perdón por mi torpeza, mi cuerpo ya pide cama aquí son las 00 y estoy despierto desde las 6am

Ve a descansar y cuando tengas el ejemplo completo me lo envías.

¡Gracias! Por tu ayuda que siempre me gustaron tus rápidas y eficaces respuestas siempre se puede contar con tus savias respuestas.

Pero esta vez logre hacerlo solo después de dormir tuve la mente despejada y un poco de tiempo en el trabajo.

Sub Importar_Datos()
'
'    Por.Dante Amor
'
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Valores")
    Set h2 = l1.Sheets("Resumen")
    h2.Cells.ClearContents
    '
    ruta = h1.[B5]
    hoja = h1.[B6]
    fila = h1.[B7]
    colu = h1.[B8]
    '
    mensaje = validaciones(ruta, hoja, fila, colu)
    If mensaje <> "" Then
        MsgBox mensaje, vbExclamation, "IMPORTAR ARCHIVOS"
        Exit Sub
    End If
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    Application.Calculation = xlCalculationManual
    '
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    arch = Dir(ruta & "*.xls*")
    i = 0
    Do While arch <> ""
        i = i + 1
        Application.StatusBar = "Importando Libro : " & i & " de : " & n
        Set l2 = Workbooks.Open(ruta & arch)
        existe = False
        If IsNumeric(hoja) Then
            If l2.Sheets.Count >= hoja Then
                existe = True
                Set h22 = l2.Sheets(hoja)
            Else
            End If
        Else
            For Each h In l2.Sheets
                If LCase(h.Name) = LCase(hoja) Then
                    existe = True
                    Set h22 = l2.Sheets(hoja)
                    Exit For
                End If
            Next
        End If
        '
        If existe Then
            u22 = h22.Range(colu & Rows.Count).End(xlUp).Row
            u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
            h22.Rows(fila & ":" & u22).Copy
            h2.Range("A" & u2).PasteSpecial xlValues
        End If
        '
        l2.Close False
        arch = Dir()
    Loop
    '
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    '
    ' nuevo
    Sheets("Resumen").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Paletten-Nr"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "LS-Datum"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "LS-Nummer"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Kanal"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Artikel"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Collo"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Menge"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Artikel-Bez"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Einzel-VKP"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Gesamt-VKP"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Bemerkungen"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Aufkäufer"
    Columns("B:B").Select
    Selection.NumberFormat = "dd.mm.yyyy;@"
    Range("A1").Select
    '
    MsgBox "Proceso terminado, archivos importados a la hoja resumen", vbInformation, "IMPORTAR ARCHIVOS"
End Sub
'
Function validaciones(ruta, hoja, fila, colu)
    validaciones = ""
    If ruta = "" Then
        validaciones = "Escribe la Carpeta donde están los archivos"
        Exit Function
    End If
    If Dir(ruta, vbDirectory) = "" Then
        validaciones = "No existe la Carpeta"
        Exit Function
    End If
    If hoja = "" Then
        validaciones = "Escribe el nombre o número de hoja"
        Exit Function
    End If
    If fila = "" Or Not IsNumeric(fila) Or fila < 1 Then
        validaciones = "Escribe la fila inicial"
        Exit Function
    End If
    If colu = "" Or IsNumeric(colu) Then
        validaciones = "Escribe la columna principal"
        Exit Function
    End If
    '
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    arch = Dir(ruta & "*.xls*")
    n = 0
    Do While arch <> ""
        n = n + 1
        arch = Dir()
    Loop
    If n = 0 Then
        validaciones = "No hay archivos de excel a importar en la carpeta : " & ruta
        Exit Function
    End If
End Function

De todos modos mil... gracias otra vez querido amigo.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas