Extraer rango de datos de una tabla con un mismo codigo a tabla
publicado
Por favor el código abajo descrito , necesite que funcione con tablas
Sub REP_FUNC()
'BUSQUEDA POR CEDULA
Set h1 = Sheets("DATA")
Set h2 = Sheets("REP-FUNC")
u2 = h2.Range("F" & Rows.Count).End(xlUp).Row
If u2 < 2 Then u2 = 2 'linea de inicio
h2.Range("F" & u2 & ":N" & u2).ClearContents
'h2.Range("F" & u2 & ":K" & u2).ClearContents
j = 2
celda = "A1" 'CELDA DE LA CONSULTA
Set r = h1.Columns("E") 'COLUMNA DE CONSULTA DATA
Set b = r.Find(h2.Range(celda), lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
h1.Range(h1.Cells(b.Row, "A"), h1.Cells(b.Row, "I")).Copy
'h1.Range(h1.Cells(b.Row, "F"), h1.Cells(b.Row, "K")).Copy
h2.Cells(j, "F").PasteSpecial Paste:=xlValues
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
End Sub
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
Por favor el código abajo descrito , necesite que funcione con tablas
Sub REP_FUNC()
'BUSQUEDA POR CEDULA
Set h1 = Sheets("DATA")
Set h2 = Sheets("REP-FUNC")
u2 = h2.Range("F" & Rows.Count).End(xlUp).Row
If u2 < 2 Then u2 = 2 'linea de inicio
h2.Range("F" & u2 & ":N" & u2).ClearContents
'h2.Range("F" & u2 & ":K" & u2).ClearContents
j = 2
celda = "A1" 'CELDA DE LA CONSULTA
Set r = h1.Columns("E") 'COLUMNA DE CONSULTA DATA
Set b = r.Find(h2.Range(celda), lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
h1.Range(h1.Cells(b.Row, "A"), h1.Cells(b.Row, "I")).Copy
'h1.Range(h1.Cells(b.Row, "F"), h1.Cells(b.Row, "K")).Copy
h2.Cells(j, "F").PasteSpecial Paste:=xlValues
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
End Sub