Macro copiar varios CSV en un libro especifico añadiendo el nombre del fichero en la primera columna al copiar
Necesito copiar varios CSV a un libro en la primera hoja (pero no uno nuevo ya que tengo formulas y las necesito mantener) añadiendo el nombre de cada fichero CSV en la primera Columna.
El problema es que los ficheros CSV contienen los mismas datos, pero para poder identificarlos y posterior análisis necesito saber que cada CSV corresponde a un entorno y añadiendo el nombre del fichero en proceso del copiado ya me resuelve este problema, le estoy dando vueltas de como hacerlo y no lo consigo.
- Copiar varios CSV en una hoja de un libro especifico y en una hoja especifica.
- Los CSV debo copiar en un rango especifico, sin las 2 primeras filas y sin las 2 ultimas filas, cada CSV contienen mas datos o menos datos, por lo tanto rango tiene que contar hasta el ultimo campo escrito.
- Introducir el nombre de cada fichero CSV en la primera columna al copiar.
Os agredeceria si alguien me puede ayudar o orientar en como realizar la Macro en Excel, me estoy volviendo loco ya que son varias puntos a tener en cuenta.
1 Respuesta
Respuesta de Vandge Wise
1
Este es el código que tengo actualmente, necesito incluir en la copia de los CSV en nombre de cada fichero con la copia de sus datos en la primera columna... y no lo consigo...
Ayuda por favor...
Sub Importar_Datos()
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 & "*.csv*")
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
Perdón vuelvo a copiar el código sin las comillas...
Sub Importar_Datos()
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 & "*.csv*")
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
