Importar datos de varios libros
Dispongo de una macro que importa datos específicos de diferentes libros en la misma carpeta, los cuales se los asigna en una hoja de control y lo copia al libro activo, lo que quisiera es poder hacer que tome los valores de ubicación mediante vba. (Activeworkbock), para no tener que poner la ubicación de manera manual, lo mismo con los otros datos, hoja activa,
Sub Importar_Datos()
'
' Por.Dante Amor
'
'
On Error Resume Next
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Valores")
Set h2 = l1.Sheets("Resumen")
h2.Cells.ClearContents
'trate de cambiar por activeworkbock.path en ruta, pero se cierra el libro. Ruta = ruta del libro activo hoja = hoja activa fila = 29 colu = c
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"
On Error Resume Next
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
On Error Resume Next
End Function
Seria lo único que no puedo realizar, después la macro cumple con su función usando el método original, pero el cual quiero cambiarlo para evitar posibles errores de ubicación más adelante.
1 Respuesta
Mereces el premio a la perseverancia ;)
A la macro que te envié le agregué la instrucción para devolverte también el nombre de la hoja, tal como se observa en la siguiente imagen. Ahora te queda adaptarla a tu modelo.
Sub solicitaRango()
'x Elsamatilde
Dim rango As Range, libro As String, hoja As String
Dim miLibro As Workbook, miHoja As Worksheet
Set miLibro = ActiveWorkbook
Set miHoja = miLibro.Sheets("Hoja3") 'hoja donde guardar la referencia
'controlamos posibles errores
On Error Resume Next
Set rango = Application.InputBox("Seleccione una celda o rango", Type:=8)
'si el rango no está vacío lo seleccionamos
If Not rango Is Nothing Then
'guardamos nombre del libro y el rango seleccionado
libro = ActiveWorkbook.Name
hoja = ActiveSheet.Name
dire = rango.Address(False, False)
With miHoja
x = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & x) = libro
.Range("B" & x) = hoja
.Range("C" & x) = dire
End With
End If
'se devuelve el control de errores a su estado normal
On Error GoTo 0
'regresa al libro/hoja de trabajo
miLibro.Activate
miHoja.Select
End Sub
