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
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
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
¡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.
- Compartir respuesta