Copiar datos de un libro a otro con búsqueda(Ctrl+B"3500")
Esta vez solicito de su apoyo con una macro en la cual necesito abrir otro archivo y pegar los datos de las columnas C:BW el problema radica en cuanto al rango inicial ya que como es en una bitacora de clientes tanto pueden haber altas como bajas no siempre va a ser el mismo aparte de que cuento con las rutas de reparto (3100) y rutas de Venta (3500 o superior)
Ruta nud nombre negocio giro
3100 21682 Flor Abarrotes
3100 21683 Arriba Chepe Abarrotes
3100 21684 La Morena Abarrotes
3100 21685 Mari Abarrotes
3100 21686 Lizeth Abarrotes
3100 21687 La Ventanita Abarrotes
3123 21254 Estrada Abarrotes
3124 21336 La Ventanita Abarrotes
3128 21469 Tasiro Abarrotes
3129 21525 Dary Abarrotes
3137 21113 Fili Abarrotes
3138 21409 Yolis Abarrotes
3140 20392 Emilio Abarrotes
3141 20630 Mi Quesito Cremería
3155 17 La Esperanza Abarrotes
3155 19 La Cumbre Abarrotes
3155 22 La Huasteca Abarrotes
3155 30 Moctezuma Abarrotes
3155 253 Six Tecate Abarrotes
3155 254 Vero II Abarrotes
3156 247 Mejia Abarrotes
3500 21682 Flor Abarrotes
3500 21683 Arriba Chepe Abarrotes
3500 21684 La Morena Abarrotes
3500 21685 Mari Abarrotes
3500 21686 Lizeth Abarrotes
3500 21687 La Ventanita Abarrotes
3522 21254 Estrada Abarrotes
3523 21336 La Ventanita Abarrotes
3527 21469 Tasiro Abarrotes
3528 21525 Dary Abarrotes
3535 21113 Fili Abarrotes
3536 21409 Yolis Abarrotes
3538 20392 Emilio Abarrotes
3551 17 La Esperanza Abarrotes
3551 22 La Huasteca Abarrotes
3551 30 Moctezuma Abarrotes
3551 254 Vero II Abarrotes
3552 247 Mejia Abarrotes
3603 20630 Mi Quesito Cremería
3903 19 La Cumbre Abarrotes
3903 253 Six Tecate Abarrotes
Y solo necesito los registros de las rutas arriba de 3500 copiarlos a mi otro libro ya intente con una macro con un CTRL+B pero me respeta el rango con el cual se grabo la macro
Sub Macro1()
'
' Macro1 Macro
'
'
ChDir "C:\Test"
Workbooks.Open Filename:="C:\Test\2016 Bitacora Electronica.xlsm"
ActiveSheet.Next.Select
Columns("C:C").Select
Selection.Find(What:="3500", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("C13470:F13470").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Libro1").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Mi duda es como seria la sentencia para que pueda guardar la instruccion de busqueda del primer valor de ruta 3500 en la columna "C" y de ahi partir a copiar hacia abajo como si fuera un ultima fila pero en este caso seria para el primer dato a seleccionar de antemano agradezco todo el apoyo brindado
2 respuestas
Te anexo la macro con los cambios, solamente en esta línea de la macro, cambia "Hoja1" por el nombre de la hoja que contiene la información a copiar.
hoja = "Hoja1"
Lo anterior es porque en tu macro tienes esta línea: ActiveSheet.Next.Select, eso significa que después de abrir el archivo se va a la siguiente hoja, pero puede ser que el libro se abra en una hoja diferente y entonces no copie la información adecuada, es por eso que si pones la hoja, siempre va a copiar la información correcta.
La macro:
Sub Macro1()
'
' Macro1 Macro
Application.ScreenUpdating = False
hoja = "Hoja1"
'
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
celda = ActiveCell.Address
Set l2 = Workbooks.Open(Filename:="C:\Test\2016 Bitacora Electronica.xlsm")
Set h2 = l2.Sheets(hoja)
Set b = h2.Columns("C:C").Find(What:="3500", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not b Is Nothing Then
u = h2.Range("C" & Rows.Count).End(xlUp).Row
h2.Range("C" & b.Row & ":F" & u).Copy
h1.Range(celda).PasteSpecial Paste:=xlPasteValues
End If
l2.Close False
Application.ScreenUpdating = True
End Sub.
.
Hola muchas gracias el código me manda un error 13 en tiempo de ejecución no coinciden los tipos y me lo marca en la siguiente línea
Set b = h2.Columns("C:C").Find(What:="3500", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Cambia esa línea por esta:
Set b = h2.Columns("C:C").Find(What:="3500", LookAt:=xlPart)sal u dos
Prueba esta macro, hace una ordenación de datos, luego realiza una búsqueda de donde inicia el primer registro con 3500, partiendo de este cuenta todos ls registros iguales o superiores a 3500 y los copia a un nuevo libro.
Sub copiar()
libro_actual = ActiveWorkbook.Name
Set datos = Workbooks(libro_actual).Sheets("hoja1").Range("c1").CurrentRegion
With datos
c = .Columns.Count
.Sort key1:=Range(.Columns(1).Address), order1:=xlAscending, Header:=xlYes
fila = WorksheetFunction.Match(3500, .Columns(1), 0)
cuenta = WorksheetFunction.CountIf(.Columns(1), ">=3500")
Set origen = .Rows(fila).Resize(cuenta)
End With
Set lb = Workbooks.Add
Set destino = lb.Worksheets("hoja1").Range("a2").Resize(cuenta, c)
With destino
.Value = origen.Value
.Rows(0).Value = datos.Rows(1).Value
End With
Set destino = Nothing: Set origen = Nothing: Set datos = Nothing
End Sub
Una pregunta esta macro abre el archivo 2016 bitácora electronica y un dato que me faltaba como lo hizo ver Dante la hoja donde están los datos se llama "base be2" es que leyendo el código noto que no se encuentra la instrucción de apertura de archivo o directorio de donde sale el archivo
Era solo un ejemplo para que lo adaptaras a lo que necesitas
Sub copiar()
ChDir "C:\Test"
Workbooks.Open Filename:="C:\Test\2016 Bitacora Electronica.xlsm"
libro_actual = ActiveWorkbook.Name
Set datos = Workbooks(libro_actual).Sheets("base be2").Range("c1").CurrentRegion
With datos
c = .Columns.Count
.Sort key1:=Sheets("base be2").Range(.Columns(1).Address), order1:=xlAscending, Header:=xlYes
fila = WorksheetFunction.Match(3500, .Columns(1), 0)
cuenta = WorksheetFunction.CountIf(.Columns(1), ">=3500")
Set origen = .Rows(fila).Resize(cuenta)
End With
Set lb = Workbooks.Add
Set destino = lb.Worksheets("hoja1").Range("a2").Resize(cuenta, c)
With destino
.Value = origen.Value
.Rows(0).Value = datos.Rows(1).Value
End With
Set destino = Nothing: Set origen = Nothing: Set datos = Nothing
End Sub