Imprimir página | Cerrar ventana

buscarv múltiples resultados

Impreso de: Foro de Access y VBA
Categoría: Otros de Microsoft: Windows y Office
Nombre del foro: Excel
Descripción del foro: Foro de Excel y VBA de Excel
URL: http://www.mvp-access.com/foro/forum_posts.asp?TID=85085
Fecha de impresión: 26/Marzo/2026 a las 19:24


Tema: buscarv múltiples resultados
Publicado por: Elenam_80
Asunto: buscarv múltiples resultados
Fecha de publicación: 23/Marzo/2020 a las 13:08
Hola!
Estoy intentando hacer un buscarv en una tabla con múltiples resultados. De normal siempre he sabido hacerlo con uno, he intentado ir creando filtros en la hoja a buscar, pero el buscarv lo del filtro no lo reconoce, busca en toda la hoja igual.

Sería algo así:

Hoja1

CODIGO     FASES
1     A
2     A
1     B
1     C
2     C
3     A
3     B
4     C

Y en la Hoja2 que aparezca así:

CODIGO     faseA     faseB     faseC
1     A     B     C
2     A          C
3     A     B     C
4               C


En la Hoja2 ya tendría la cabecera creada. Hice una macro con un primer paso para poner en la columna 1 de la Hoja2 los códigos sin duplicados y luego había pensado en ir filtrando en la Hoja1 por cada fase y hacer el buscarv de siempre, pero no funciona. El rango que he definido sigue siendo el mismo.

(las variables ya estarían creadas antes y el rango ya lo habría definido con hoja1)

codigo = Sheets ("Hoja1").Cells (Count, 1)
fase = Application.Vlookup (codigo, rango, 2,False)

Alguna idea?

De esta forma solo me pega en la Hoja2 lo primero que encuentra de cada código.

Gracias!!




-------------
Ele


Respuestas:
Publicado por: Elenam_80
Fecha de publicación: 23/Marzo/2020 a las 14:41
Hola! Me acaban de dar la respuesta y funciona, la dejo aquí por si le sirve de ayuda a alguien ;). Sl2!

Sub reordenarFases()
'x Elsamatilde
Set ho1 = Sheets("Hoja1")
'controla que haya datos
x = ho1.Range("A" & Rows.Count).End(xlUp).Row
If x < 2 Then MsgBox "No hay datos en Hoja1": Exit Sub
'ordenar la hoja    .... opcional: en otro rango o volver a reordenarla al finalizar
If x > 2 Then
    ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=Range("A2:A" & x), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Hoja1").Sort
        .SetRange Range("A1:B9" & x)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End If
'limpiar tabla destino de posibles datos anteriores
Set ho2 = Sheets("Hoja2")
ho2.[A2].CurrentRegion.Offset(1, 0).ClearContents
y = 1    'fila de destino
'recorrer la Hoja1 y crear registro hasta cambiar de código
For i = 2 To x
    'si cambia de código se pasa a fila sgte en destino
    If ho1.Range("A" & i) <> codi Then
        codi = ho1.Range("A" & i)
        y = y + 1
        ho2.Range("A" & y) = codi
    End If
    Set busco = ho2.Rows("1:1").Find("Fase" & ho1.Range("B" & i), LookIn:=xlValues, lookat:=xlWhole)
    If Not busco Is Nothing Then
        ho2.Cells(y, busco.Column) = ho1.Range("B" & i)
    End If
Next i
MsgBox "Fin del proceso"
End Sub

-------------
Ele

Publicado por: AnSanVal
Fecha de publicación: 23/Marzo/2020 a las 19:48
Un poco más corto:

Sub Reparte()

  Dim celda As Range, fila&, filau&, col&

  filau = Cells(Rows.Count, 1).End(xlUp).Row

  [CC1] = [B1]

  Range("B1:B" & filau).AdvancedFilter Action:=xlFilterCopy, _

      CopyToRange:=Range("CC1"), Unique:=True

  With Worksheets(2)

    .Range("A1").CurrentRegion.Offset(1).ClearContents

    For Each celda In Range("A2:A" & filau)

      fila = celda.Value + 1

      col = WorksheetFunction.Match(celda.Offset(, 1), Range("CC1:CC100"), 0)

      .Cells(fila, 1).Value = celda.Value

      .Cells(fila, col).Value = celda.Offset(, 1).Value

    Next celda

  End With

  Range("CC1").CurrentRegion.ClearContents

End Sub






-------------
Saludos desde Tenerife.


Imprimir página | Cerrar ventana