Excel, como mejorar macro para búsqueda, copiar y pegar en otra hoja
Necesito de su valiosa experiencia, en resumidas cuentas, la macro lo que tiene que hacer es pasar del archivo llamado RATIFICADO todos los folios de los predios de cada productor al archivo que dice TABLAORI, una parte del archivo esta llenado que fue de forma manual de cómo quedaría, pero son muchos registros y se pierde mucho tiempo, si me pudieras apoyar en optimizarla y corregirla, ya que cuando los dos datos de los dos archivos están por orden y coinciden no hay problema, pero si por pura casualidad en el archivo TABLAORI están sin ordenar, truena la macro.
Sub Traer()
Contador = 4
Contador2 = 30
encontrado = False
Sheets("RATIFICADO").Select
Do While Cells(Contador, 3) <> "" And Cells(Contador + 1, 3) <> ""
encontrado = False
Cells(Contador + 1, 3).Select
Productor = ActiveCell.Value
Predio = ActiveCell.Offset(0, 1).Value
Sheets("TABLAORI").Select
Cells(Contador2, 1).Select
Productor2 = ActiveCell.Value
Do While encontrado = False
If Productor = Productor2 Then
Sheets("TABLAORI").Select
Cells(Contador2, 1).Select
ActiveCell.Offset(0, 1) = Predio
Contador2 = Contador2 + 1
AuxProductor = Productor2
Nombre = ActiveCell.Offset(0, 2)
Paterno = ActiveCell.Offset(0, 3)
Materno = ActiveCell.Offset(0, 4)
encontrado = True
Else
If Productor = AuxProductor Then
For i = 1 To 25
Cells(Contador2, i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
Cells(Contador2, 1).Value = AuxProductor
ActiveCell.Offset(0, 2) = Nombre
ActiveCell.Offset(0, 3) = Paterno
ActiveCell.Offset(0, 4) = Materno
Contador = Contador - 1
encontrado = False
Else
Contador2 = Contador2 + 1
Predio = ""
Cells(Contador2, 1).Select
ActiveCell.Offset(0, 1) = Predio
Contador = Contador - 1
encontrado = False
End If
End If
Loop
Contador = Contador + 1
Sheets("RATIFICADO").Select
Loop
End Sub
P.D. Adjunto como están los datos en excel.
1 respuesta
H o l a:
Con gusto te actualizo tu macro.
Explícame lo que tienes:
- ¿Tienes un libro con 2 hojas?
- ¿O tienes 2 libros?
Envíame tu archivo y me explicas con ejemplos, ¿colores y comentarios cómo se debe pasar la información de dónde a dónde?
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Javier Alejandro Encarnacion Peña” y el título de esta pregunta.
Hola, ya esta enviada la información como me lo pediste..
Saludos..
Javier Peña
Te anexo la macro
Sub FolioPredio()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.StatusBar = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
Set l2 = Workbooks("tablaori.xlsx")
Set h2 = l2.Sheets(1)
'
u2 = h2.Range("B" & Rows.Count).End(xlUp).Row
h2.Range("B30:B" & u2).ClearContents
u = h1.Range("C" & Rows.Count).End(xlUp).Row
'
For i = 5 To u
Application.StatusBar = "Procesando fila: " & i & " de: " & u
folio = h1.Cells(i, "C")
Set r = h2.Columns("A")
Set b = r.Find(folio, lookat:=xlWhole)
existe = False
If Not b Is Nothing Then
ncell = b.Address
'fila = b.Row
Do
'detalle
If b.Offset(0, 1) = "" Then
b.Offset(0, 1) = h1.Cells(i, "D")
existe = True
Exit Do
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
If existe = False Then
Set b = h2.Columns("A").Find("TOTAL", lookat:=xlPart)
If Not b Is Nothing Then
h2.Rows(b.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
h2.Cells(b.Row - 1, "A") = folio
h2.Cells(b.Row - 1, "B") = h1.Cells(i, "B")
End If
End If
Next
Application.StatusBar = False
MsgBox "Fin"
End Sub' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
¡Gracias! , EXCELENTE TODO!!!!, eres genial, ya estaba hecho bolas con tantas funciones, te lo agradezco infinitamente, que tengas un excelente fin de semana.. Saludos
Javier Peña
