• 💪 Demuestra tus super conocimientos de Excel 
    Ayúdanos a contestar estos temas sin respuesta

buscarv múltiples resultados o match

Mario80

New member
Hola!
Estoy intentando hacer un buscarv en una tabla con múltiples resultados. lo consigo en VB con vlookup pero solo si es para un resultado. Me han enviado una solución, pero solo funciona si la primera columna es numérica, si es alfanumérica me dice que no coinciden los tipos. Llevo un rato intentando cambiar la variable a tipo double o string, pero siempre sale un error distinto, alguna idea?

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


sería convertir esto:

CODIGO VALOR
X1 1
U2 1
X1 2
U2 3

en

CODIGO VALOR 1 VALOR 2 VALOR 3
X1 1 2
U2 1 3


Me funciona si la column a código es numérica, pero de esta manera no. Alguna idea?
gracias!!!
 

Cacho R

Well-known member
Hola! Mario80. Te muestro una forma de hacerlo:
JavaScript:
Sub Reparte()
Dim i%, Dic, iKey: Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To [a1].End(xlDown).Row
  iKey = CStr(Cells(i, "a"))
  If Dic.Exists(iKey) Then
    Dic(iKey) = Dic(iKey) & "|" & Cells(i, "b").Value
  Else
    Dic(iKey) = Cells(i, "b").Value
  End If
Next
[a1:b1].Copy [e1]: [e1].CurrentRegion.Offset(1).Delete xlShiftUp
[e2].Resize(Dic.Count) = WorksheetFunction.Transpose(Dic.keys)
Dic = Dic.Items
For i = 2 To [e1].End(xlDown).Row
  iKey = Split(Dic(i - 2), "|")
  Cells(i, "f").Resize(, 1 + UBound(iKey)).FormulaArray = iKey
Next
End
End Sub
 

_Tato_

Member
Hola! Mario80. Te muestro una forma de hacerlo:
JavaScript:
Sub Reparte()
Dim i%, Dic, iKey: Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To [a1].End(xlDown).Row
  iKey = CStr(Cells(i, "a"))
  If Dic.Exists(iKey) Then
    Dic(iKey) = Dic(iKey) & "|" & Cells(i, "b").Value
  Else
    Dic(iKey) = Cells(i, "b").Value
  End If
Next
[a1:b1].Copy [e1]: [e1].CurrentRegion.Offset(1).Delete xlShiftUp
[e2].Resize(Dic.Count) = WorksheetFunction.Transpose(Dic.keys)
Dic = Dic.Items
For i = 2 To [e1].End(xlDown).Row
  iKey = Split(Dic(i - 2), "|")
  Cells(i, "f").Resize(, 1 + UBound(iKey)).FormulaArray = iKey
Next
End
End Sub
Hola Cacho, ¿puedes poner el excel donde has aplicado el código para verlo paso a paso e intentar aprender por favor?

Muchas gracias y un saludo,
 

Cacho R

Well-known member
Hola Cacho, ¿puedes poner el excel donde has aplicado el código para verlo paso a paso e intentar aprender por favor?

Muchas gracias y un saludo
Son dos simples columnas que ocupan el rango A1:B5... ¡Tal como lo muestra el consultante!, Tato. :D
 

Mario80

New member
Hola! Mario80. Te muestro una forma de hacerlo:
JavaScript:
Sub Reparte()
Dim i%, Dic, iKey: Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To [a1].End(xlDown).Row
  iKey = CStr(Cells(i, "a"))
  If Dic.Exists(iKey) Then
    Dic(iKey) = Dic(iKey) & "|" & Cells(i, "b").Value
  Else
    Dic(iKey) = Cells(i, "b").Value
  End If
Next
[a1:b1].Copy [e1]: [e1].CurrentRegion.Offset(1).Delete xlShiftUp
[e2].Resize(Dic.Count) = WorksheetFunction.Transpose(Dic.keys)
Dic = Dic.Items
For i = 2 To [e1].End(xlDown).Row
  iKey = Split(Dic(i - 2), "|")
  Cells(i, "f").Resize(, 1 + UBound(iKey)).FormulaArray = iKey
Next
End
End Sub

Mil gracias!!! Funciona perfecto! Ahora a estudiar cómo lo has hecho ;). Gracias, de nuevo!
 
Arriba