Copiar múltiples parámetros con consulta sql en excel y vba

Tengo el siguiente código y necesito sacar dellibro POR varios datos que están en distintas celdas y así mismo que cada rango se copie a otro rango de otro libro Y

Ejemplo del libro POR de la hoja "xhoja1" copiar el rango "A1:a10" y pegargo en el libro Y en la hoja "yHoja1" en el rango "D10:D20" creo que es importante mencionar que el código que tengo extrae la inf del libro sin necesidad de abrirlo porque el libro tarda demasiado en abrir aproximadamente 10 mnts si alguien puede ayudarme le agradecería de antemanos espero su apoyo

Sub g11()
Dim strArchivo As String, strSQL As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim arrData As Variant
strArchivo = "C:\Users\DEM5TL\Desktop\GPG-595.xls"
'Comprobamos si el archivo existe en la ruta indicada
If Dir(strArchivo) = "" Then
MsgBox "No existe el archivo en la ruta indicada."
Exit Sub
End If
'Creamos la cedena texto de la consulta SQL
strSQL = "SELECT * FROM [Paso 3 BTS$a10:a19] "
'Creamos la conexion al archivo
Set cn = New ADODB.Connection
cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"DriverIdy0;ReadOnly=True;DBQ=" & strArchivo & ";"
'Extraemos los datos
Set rs = New ADODB.Recordset
rs.Open strSQL, cn, adOpenForwardOnly, _
adLockReadOnly, adCmdText
'Copiamos los datos en la celda destino
Workbooks("Macro2V1.xlsx").Worksheets("1-1") _
.Range("c5:c19").CopyFromRecordset rs
'Cerramos la conexion y vaciamos las variables
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

1 Respuesta

Respuesta
1

H o l a:

No me funciona esta conexión que estás poniendo:

cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};" & "DriverIdy0;ReadOnly=True;DBQ=" & strArchivo & ";"

La que me funciona es esta:

    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strArchivo _
                & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
    cn.Open strCon

Prueba la macro con la misma conexión que estoy utilizando:

Sub g11()
'Act.Por.Dante Amor
    Dim strArchivo As String, strSQL As String
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim arrData As Variant
    '
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    '
    strArchivo = "C:\Users\DEM5TL\Desktop\GPG-595.xls"
    'strArchivo = ThisWorkbook.Path & "\" & "datosx.xlsx"
    'Comprobamos si el archivo existe en la ruta indicada
    If Dir(strArchivo) = "" Then
        MsgBox "No existe el archivo en la ruta indicada."
        Exit Sub
    End If
    strSQL = "SELECT * FROM [Paso 3 BTS$A10:A19] "
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strArchivo _
                & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
    'strCon = "DRIVER={Microsoft Excel Driver (*.xls)};" & "DriverIdy0;ReadOnly=True;DBQ=" & strArchivo & ";"
    cn.Open strCon
    rs.Open strSQL, cn
    Workbooks("Macro2V1.xlsx").Worksheets("1-1").Range("C5").CopyFromRecordset rs
    '
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub


Si no te funciona, entonces quita el apostrofe ( ' ) para que utilices el que sí te funciona, en esta línea:

'strCon = "DRIVER={Microsoft Excel Driver (*.xls)};" & "DriverIdy0;ReadOnly=True;DBQ=" & strArchivo & ";"

Bien, ahora dime qué rangos quieres copiar del libro "GPG-595.xls" y en dónde los quieres pegar.

Por ejemplo:c

Rango                                   Celda destino

A10:A19                                       C5

Rango2?                                      celda2?

rango3?                                     celda3?

etc...

NOTA: el libro Macro2V1.xlsx, deberá estar abierto para poder pegar los datos.


sal u dos

Hola dante en cuanto a la conexión no tengo problemas

Parece que funciona bien tal como esta de la siguiente manera :

Y quedaría de la siguiente forma del libro EKP.xlsx

De la hoja Sheet1 y del

Rango B33:B38 este rango se copiara a el libro Macro2V1.xlsx en la hoja de nombre "2-9" en el rango de c5:10

Luego los rangos van de la siguiente manera respectivamente

g33:g38 a c14:c19

l33:l38 a c23:c28

q33:q38 a c32:c37

v33:v38 a c41:c46

AA33:AA38 a c50:c55

AF33:AF38 a c59:c64

Y si no tengo problema en que Macro2V1.xlsx este activo de antemano gracias por tu ayuda y espero tu respuesta .


strArchivo = "I:\Dept\CLP\Shared\RegistroNegocio\Empaques\DyDClientes_20_Años\BTS\Respaldo BTS\2014\CW52\BTS LINEAS\EKP.xlsx"
'Comprobamos si el archivo existe en la ruta indicada
If Dir(strArchivo) = "" Then
MsgBox "No existe el archivo en la ruta indicada."
Exit Sub
End If
'Creamos la cedena texto de la consulta SQL
strSQL = "SELECT * FROM [Sheet1$B32:B38] "
'Creamos la conexion al archivo
Set cn = New ADODB.Connection
cn.Open "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"DriverIdy0;ReadOnly=True;DBQ=" & strArchivo & ";"
'Extraemos los datos
Set rs = New ADODB.Recordset
rs.Open strSQL, cn, adOpenForwardOnly, _
adLockReadOnly, adCmdText
'Copiamos los datos en la celda destino
Workbooks("Macro2V1.xlsx").Worksheets("2-9") _
.Range("c5:c10").CopyFromRecordset rs

Te anexo la macro actualizada para copiar los rangos:

Sub CopiaRangos()
'Por.Dante Amor
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    '
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    '
    strArchivo = "I:\Dept\CLP\Shared\RegistroNegocio\Empaques\DyDClientes_20_Años\BTS\Respaldo BTS\2014\CW52\BTS LINEAS\EKP.xlsx"
    'strArchivo = ThisWorkbook.Path & "\" & "datosx.xlsx"
    'Comprobamos si el archivo existe en la ruta indicada
    If Dir(strArchivo) = "" Then
        MsgBox "No existe el archivo en la ruta indicada."
        Exit Sub
    End If
    '
    rangos = Array("B33:B38", "g33:g38", "l33:l38", "q33:q38", "v33:v38", "AA33:AA38", "AF33:AF38")
    celdas = Array("C5", "C14", "C23", "C32", "C41", "C50", "C59")
    '
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strArchivo _
                & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
    cn.Open strCon
    For i = LBound(rangos) To UBound(rangos)
        strSQL = "SELECT * FROM [Sheet1$" & rangos(i) & "]"
        rs.Open strSQL, cn
        Workbooks("Macro2V1.xlsx").Worksheets("2-9").Range(celdas(i)).CopyFromRecordset rs
        rs.Close
    Next
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
    MsgBox "Proceso terminado", vbInformation, "COPIAR RANGOS"
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas