Jump to content

Buscarv solo en celdas visibles


Go to solution Solved by Antoni,

Recommended Posts

  • Solution
Posted (edited)

Un enfoque sin utilizar filtro.

Sub Buscar()
Application.ScreenUpdating = False
Sheets("Hoja2").Activate
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents
With Hoja1
   For x = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Range("B" & x) = "B" Then
         Set celda = Columns("A").Find(.Range("A" & x), , , xlWhole)
         If Not celda Is Nothing Then
            Range("B" & celda.Row) = .Range("C" & x)
         End If
      End If
   Next
End With
End Sub

 

Edited by Antoni
Link to comment
Share on other sites

Hace 7 minutos , Antoni dijo:

Un enfoque sin utilizar filtro.

Te me adelantastes por la mano... :rolleyes:

@Maria_80,no puedes usar directamente VlookUp directamente sobre un rango filtrado. Otro enfoque con el filtro

Sub buscar_filtrados()
Dim rng, cel As Range, ufo&, ufd&

If Worksheets("Hoja1").FilterMode Then Worksheets("Hoja1").ShowAllData 'Quitamos el filtro
Worksheets("Hoja1").Range("B1").AutoFilter Field:=2, Criteria1:="B", Operator:=xlFilterValues

ufo = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Sheets("Hoja1").Range("A2:A" & ufo).SpecialCells(xlCellTypeVisible)

Sheets("Hoja2").Activate
ufd = Range("A" & Rows.Count).End(xlUp).Row

For Each cel In rng
    For x = 2 To ufd
        If Cells(x, 1) = cel Then
            Cells(x, 2) = cel.Offset(, 2)
            Exit For
        End If
    Next x
Next cel

End Sub

 

Link to comment
Share on other sites

Otra versión mas

Sub BuscarVisibles()

Application.ScreenUpdating = False

Set rango = Hoja2.Range("A2", Hoja2.Range("A1").End(xlDown))
rango.Offset(, 1).ClearContents

For Each c In rango

Set vpb = Hoja1.Range("A:A").Find(c, , , xlWhole)
If Not vpb Is Nothing Then
    f = c.Row: f2 = vpb.Row
    Hoja2.Cells(f, "B") = Hoja1.Cells(f2, "C")
End If

Next

Hoja2.Select
Set vpb = Nothing: Set rango = Nothing

Application.ScreenUpdating = True

End Sub

 

Saludos!

Link to comment
Share on other sites

16 hours ago, Antoni said:

Un enfoque sin utilizar filtro.

Sub Buscar()
Application.ScreenUpdating = False
Sheets("Hoja2").Activate
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents
With Hoja1
   For x = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Range("B" & x) = "B" Then
         Set celda = Columns("A").Find(.Range("A" & x), , , xlWhole)
         If Not celda Is Nothing Then
            Range("B" & celda.Row) = .Range("C" & x)
         End If
      End If
   Next
End With
End Sub

 

Gracias, Antoni! No encontraba nada por ahí. Funcionan todas las soluciones, aunque voy a desarrollar sobre esta, es la que he podido entender mejor para adaptarlo a lo mío y de momento genial. Gracias de nuevo!

Link to comment
Share on other sites

16 hours ago, Gerson Pineda said:

Otra versión mas

Sub BuscarVisibles()

Application.ScreenUpdating = False

Set rango = Hoja2.Range("A2", Hoja2.Range("A1").End(xlDown))
rango.Offset(, 1).ClearContents

For Each c In rango

Set vpb = Hoja1.Range("A:A").Find(c, , , xlWhole)
If Not vpb Is Nothing Then
    f = c.Row: f2 = vpb.Row
    Hoja2.Cells(f, "B") = Hoja1.Cells(f2, "C")
End If

Next

Hoja2.Select
Set vpb = Nothing: Set rango = Nothing

Application.ScreenUpdating = True

End Sub

 

Saludos!

Gracias, funciona del diez!

Link to comment
Share on other sites

16 hours ago, Haplox said:

Te me adelantastes por la mano... :rolleyes:

@Maria_80,no puedes usar directamente VlookUp directamente sobre un rango filtrado. Otro enfoque con el filtro

Sub buscar_filtrados()
Dim rng, cel As Range, ufo&, ufd&

If Worksheets("Hoja1").FilterMode Then Worksheets("Hoja1").ShowAllData 'Quitamos el filtro
Worksheets("Hoja1").Range("B1").AutoFilter Field:=2, Criteria1:="B", Operator:=xlFilterValues

ufo = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Sheets("Hoja1").Range("A2:A" & ufo).SpecialCells(xlCellTypeVisible)

Sheets("Hoja2").Activate
ufd = Range("A" & Rows.Count).End(xlUp).Row

For Each cel In rng
    For x = 2 To ufd
        If Cells(x, 1) = cel Then
            Cells(x, 2) = cel.Offset(, 2)
            Exit For
        End If
    Next x
Next cel

End Sub

 

Muchísimas gracias!

Link to comment
Share on other sites

×
×
  • Create New...

Important Information

Privacy Policy