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
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 SubSi 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