Buscar palabras del texto de una celda en las columnas B, C y D de otra hoja del mismo libro y crear un useform.
Necesito hacer una búsqueda de cada palabra que forma parte de cada artículo de compra (Col. A, Hoja X) (quitando letras hasta 2) en las columnas B, C y D de cada fila de la hoja "P.G.C.", crear un listado de todas ellas guardando el número de fila. Si algún número de fila es única o se repite dos o más veces, esa es nuestra fila. En ese caso debería darlo de alta la macro en "ART_COMP." poniendo la "FAMILIA, DETALLE y SUBFAMILIA" de la fila encontrada sin más preámbulos, sin necesidad de aceptarlo tras comprobación. Ahora bien, si la búsqueda arroja más de una fila distinta con solo una coincidencia, o con dos o más coincidencias un userform para decidir cual escoger y enviarlo a "ART_COMP."
¿Podrían aparecer de color rojo aquellos que tienen coincidencia? Y para los que no tienen coincidencias ¿se podría presentar dentro del userform cuatro combobox (familia, detalle, subfamilia y descripción artículo en pgc) para elegirlos y dar de alta el "ART_COMP." desde ahí? En el cuarto combobox (descripción artículo en PGC) debería permitir escribir y dar de alta uno nuevo."
Va la macro de búsqueda
Private Sub ListBox1_Click()
'Busca coincidencias
If cargando Then Exit Sub
ListBox2.RowSource = ""
h4.Rows("2:" & Rows.Count).Clear
fila = Buscar_Coincidencias(ListBox1.List(ListBox1.ListIndex, 0), 2)
If fila = 1 Then
h4.Cells.EntireColumn.AutoFit
u4 = h4.Range("A" & Rows.Count).End(xlUp).Row
col = "I"
For i = 1 To Columns(col).Column
anch = anch & Int(h4.Cells(1, i).Width) + 3 & ";"
Next
ListBox2.ColumnWidths = anch
ListBox2.RowSource = h4.Name & "!" & h4.Range("A2:" & col & u4).Address
Else
MsgBox "No hay coincidencias", vbExclamation, "COINCIDENCIAS"
End If
End Sub
'
Function Buscar_Coincidencias(articulo, op)
'Función para buscar coincidencias
If cargando Then Exit Function
Set r = h3.Columns("B:D")
arts = Split(articulo, " ")
j = 2
n = 0
salir = False
For k = LBound(arts) To UBound(arts)
p = 1
art = WorksheetFunction.Trim(arts(k))
Select Case LCase(art)
Case "de", "del", "", "-", " ", ".", ",", ";"
Case Else
If n = 2 Then
'salir = True
Exit For
End If
n = n + 1
yaexiste = False
For m = Len(art) To 2 Step -1
ya_encontro = False
Set b = r.Find(art, lookat:=xlPart)
If Not b Is Nothing Then
ya_encontro = True 'ya encontro en pgc y ya no quita letras
If op = 2 Then
celda = b.Address
wfila = 0
Do
'detalle
If b.Row <> wfila Then
For q = 2 To h4.Range("A" & Rows.Count).End(xlUp).Row
If h4.Cells(q, "J") = b.Row Then
yaexiste = True 'ya exite en temp ya no registra
Exit For
End If
Next
If yaexiste = False Then
h3.Rows(b.Row).Copy h4.Rows(j)
h4.Cells(j, "J") = b.Row
j = j + 1
End If
yaexiste = False
End If
wfila = b.Row
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
'
Buscar_Coincidencias = 1
If op = 1 Then
salir = True
Exit For
End If
If ya_encontro Then
Exit For
End If
End If
If p = 3 Then
Exit For
End If
p = p + 1
art = Left(art, Len(art) - 1)
Next
If salir Then
Exit For
End If
'end case
End Select
Next
End Function
'
Private Sub UserForm_Activate()
'Analiza artículos
Set h1 = Sheets("Revision de articulos")
Set h2 = Sheets("ART_COMP.")
Set h3 = Sheets("P.G.C.")
Set h4 = Sheets("Temp")
Set h5 = Sheets("Temp1")
'
h4.Rows("2:" & Rows.Count).Clear
h5.Rows("2:" & Rows.Count).Clear
j = 2
For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row ' Step -1
art = h1.Cells(i, "A")
Set b = h2.Columns("A").Find(art, lookat:=xlWhole)
If b Is Nothing Then
'si no encuentra, lo agrega al list para clasificar
h5.Cells(j, "A") = art
If Buscar_Coincidencias(art, 1) <> 1 Then
h5.Cells(j, "B") = "x"
End If
j = j + 1
End If
Next
u5 = h5.Range("A" & Rows.Count).End(xlUp).Row
rango = h5.Range("A2:B" & u5).Address
h5.Cells.EntireColumn.AutoFit
col = "B"
For i = 1 To Columns(col).Column
anch = anch & Int(h5.Cells(1, i).Width) + 3 & ";"
Next
ListBox1.RowSource = h5.Name & "!" & rango
ListBox1.ColumnWidths = anch
End Subsal u dos
