Abrir excel según ruta y copiar filas según columna

Estoy tratando de realizar una macro para gestión de información..

Lo que necesito es que abra el excel cuya ruta se encuentra en el "label2", se posicione en la cerda "e10" de dicho archivo y comience a recorrer la columna "e" .. Está columna tiene celdas vacías y celdas con números.. Al recorrer la columna "e" necesito que copié la fila completa en el caso de que la celda de la columna contenga valor, en el caso de que la cerda este en blanco que siga con la fila siguiente.. Y que a esta fila que copio la pegue en la hoja "QH" del libro desde el que estoy ejecutando la macro.. De esta forma en la hoja "QH" me quedarían todas las filas del archivo cuya dirección está en el "label2", en conde las celdas de la columna "e" tiene algún valor (siempre numérico)..

1 respuesta

Respuesta
1

Te anexo el código.

Faltó que definieras algunos detalles:

- El nombre del archivo que se va a abrir

- El nombre de la hoja del archivo que se va a abrir

- ¿Dentro de la hoja "QH" en cuál hoja?

- ¿Dentro de la hoja "QH" en cuál hoja y en cuál columna?

- ¿Dentro de la hoja "QH" en cuál hoja y en cuál columna y cuál fila?

Antes de ejecutar el código, cambia los datos en esta parte:

    arch = "archivo.xlsx"       'nombre del archivo
    hoja = "Hoja1"              'nombre de la hoja del archivo
    col = "E"                   'columna destino

Lo que hace la macro es poner los resultados en la columna "E", en la siguiente fila disponible.


Private Sub CommandButton1_Click()
'Por Dante Amor
    'Abrir Archivo
    '
    Application.ScreenUpdating = False
    arch = "archivo.xlsx"       'nombre del archivo
    hoja = "Hoja1"              'nombre de la hoja del archivo
    col = "E"                   'columna destino
    ruta = Label1.Caption
    '
    'VALIDACIONES
    If ruta = "" Then
        MsgBox "Falta la ruta en el label"
        Exit Sub
    End If
    If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
    If Dir(ruta, vbDirectory) = "" Then
        MsgBox "La ruta no exite"
        Exit Sub
    End If
    If Dir(ruta & arch) = "" Then
        MsgBox "El archivo no exite"
        Exit Sub
    End If
    '
    'EJECUCIÓN
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("QH")
    Set l2 = Workbooks.Open(ruta & arch)
    Set h2 = l2.Sheets(1)
    '
    For i = 10 To h2.Range("E" & Rows.Count).End(xlUp).Row
        If h2.Cells(i, "E").Value <> "" And IsNumeric(h2.Cells(i, "E").Value) Then
            u1 = h1.Range(col & Rows.Count).End(xlUp).Row + 1
            h1.Cells(u1, col).Value = h2.Cells(i, col).Value
        End If
    Next
    l2.Close False
    MsgBox "Fin"
End Sub

'.[Sal u dos. Dante Amor. No olvides valorar la respuesta. 
'.[Avísame cualquier duda

Que grande Dante.. sabía que podía contar con vos.. en el label2 está la ruta del archivo.. tanto el lugar como el nombre.. la ruta puede cambiar pero los archivos son todos iguales.. hasta tiene el mismo nombre pero el contenido varía.. la hoja dentro del archivo se llama "foglio1" y la columna que determina que filas copiar es la "e" y a partir de la fila 10.

En el archivo del cual ejecutó la macro ahí una hoja llamada "QH" en la que van pegadas las filas a partir de "A1"..

En otras palabras en la hoja "QH" de mi archivo van a quedar las filas de la hoja "foglio1" en las cuales la columna "e" a partir de la fila 10 tiene algún valor, dejando de lado las que no tengan ningún valor..

Modificó eso en la macro que me pasaste.?

Quedaría así:

Private Sub CommandButton1_Click()
'Por Dante Amor
    'Abrir Archivo
    '
    Application.ScreenUpdating = False
    hoja = "foglio1"              'nombre de la hoja del archivo
    col = "A"                   'columna destino
    ruta = Label1.Caption
    '
    'VALIDACIONES
    If ruta = "" Then
        MsgBox "Falta la ruta en el label"
        Exit Sub
    End If
    If Dir(ruta) = "" Then
        MsgBox "El archivo no exite"
        Exit Sub
    End If
    '
    'EJECUCIÓN
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("QH")
    Set l2 = Workbooks.Open(ruta)
    Set h2 = l2.Sheets(hoja)
    '
    n = 1
    For i = 10 To h2.Range("E" & Rows.Count).End(xlUp).Row
        If h2.Cells(i, "E").Value <> "" And IsNumeric(h2.Cells(i, "E").Value) Then
            h1.Cells(n, col).Value = h2.Cells(i, "E").Value
            n = n + 1
        End If
    Next
    l2.Close False
    Application.ScreenUpdating = True
    MsgBox "Fin"
End Sub

No olvides valorar la respuesta. 

Sos un genio..!!

Dante.. disculpa que te joda pero vos sabés que me salta error.. pongo depurar y me sale marcada está línea

h1.Cells(n, col).Value = h2.Cells(i, "E").Value

Me ayudas.?

Pensé que el error pudiera estar en que en la hoja "QH" ahí datos de un intento de macro que estaba haciendo pero borre esos datos y sigue el mismo error.. no sé si poner una sentencia que limpie la hoja "QH" antes de pegar.. igual creo que el drama está en otro lado pues borré todos los datos y sigue saltando el error

Después de ir haciendo unas correcciones la macro funcionó.. pero solo me trajo los valores de la columna "A" y no toda la fila.. realizó el filtrado por la columna "E" pero solo trajo los datos de la columna "A".. necesito los valores de toda la fila.. te paso cómo quedó la macro

Private Sub CommandButton2_Click()

'Por Dante Amor

'Abrir Archivo

Application.ScreenUpdating = False

hoja = "Foglio1" 'nombre de la hoja del archivo

col = "A" 'columna destino

ruta = Label2.Caption

'

'VALIDACIONES

If ruta = "" Then

MsgBox "Falta la ruta en el label"

Exit Sub

End If

If Dir(ruta) = "" Then

MsgBox "El archivo no exite"

Exit Sub

End If

'

'EJECUCIÓN

Set l1 = ThisWorkbook

Set h1 = l1.Sheets("QH")

Set l2 = Workbooks.Open(ruta)

Set h2 = l2.Sheets(hoja)

'

n = 1

For i = 10 To h2.Range("E" & Rows.Count).End(xlUp).Row

If h2.Cells(i, "E").Value <> "" And IsNumeric(h2.Cells(i, "E").Value) Then

h1.Cells(n, col).Value = h2.Cells(i, "A").Value

n = n + 1

End If

Next

l2.Close False

Application.ScreenUpdating = True

MsgBox "Fin"

End Sub.

Te anexo la macro actualizada para copiar toda la fila

Private Sub CommandButton1_Click()
'Por Dante Amor
    'Abrir Archivo
    '
    Application.ScreenUpdating = False
    hoja = "foglio1"              'nombre de la hoja del archivo
    col = "A"                   'columna destino
    ruta = Label1.Caption
    '
    'VALIDACIONES
    If ruta = "" Then
        MsgBox "Falta la ruta en el label"
        Exit Sub
    End If
    If Dir(ruta) = "" Then
        MsgBox "El archivo no exite"
        Exit Sub
    End If
    '
    'EJECUCIÓN
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("QH")
    Set l2 = Workbooks.Open(ruta)
    Set h2 = l2.Sheets(hoja)
    '
    n = 1
    For i = 10 To h2.Range("E" & Rows.Count).End(xlUp).Row
        If h2.Cells(i, "E").Value <> "" And IsNumeric(h2.Cells(i, "E").Value) Then
            'h1.Cells(n, col).Value = h2.Cells(i, "E").Value
            h2.Rows(i).Copy
            h1.Rows(n).PasteSpecial xlValues
            n = n + 1
        End If
    Next
    l2.Close False
    Application.ScreenUpdating = True
    MsgBox "Fin"
End Sub

[ sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas