Antoni

Sube tu archivo, porqué, efectivamente, no lo has hecho bien.

Después de ejecutar la macro Click, me aparece así. ¿He hecho algo mal? Saludos amigo

Una más: Sub Resumen() Dim BASE, ANUAL, FILA, COLUMNA, TEXTO, UFILA, UCOLUMNA '-- Set BASE = Sheets("BASE") Set ANUAL = Sheets("ANUAL") '-- UFILA = ANUAL.Range("A" & Rows.Count).End(xlUp).Row + 1 UCOLUMNA = ANUAL.Cells(1, Columns.Count).End(xlToLeft).Column + 1 ANUAL.Range("C2", ANUAL.Cells(UFILA, UCOLUMNA)).ClearContents '-- For x = 2 To BASE.Range("A" & Rows.Count).End(xlUp).Row If Not UCase(BASE.Range("O" & x)) = "RECHAZADO" Then Set FILA = ANUAL.Columns("A").Find(BASE.Range("E" & x), , xlValues, xlWhole) Set COLUMNA = ANUAL.Rows(1).Find(BASE.Range("I" & x), , xlValues, xlWhole) If Not FILA Is Nothing And Not COLUMNA Is Nothing Then TEXTO = "|" & BASE.Range("C" & x) & "-" & BASE.Range("D" & x) & "-" & Format(BASE.Range("M" & x), "0.00") If ANUAL.Cells(FILA.Row, COLUMNA.Column) = "" Then TEXTO = Mid(TEXTO, 2) ANUAL.Cells(FILA.Row, COLUMNA.Column) = ANUAL.Cells(FILA.Row, COLUMNA.Column) & TEXTO End If End If Next End Sub

Lo mismo, de otra manera sin considerar los acentos. Function Similitud_Porcentual(Cadena1 As String, Cadena2 As String) As Integer Dim Texto1 As Variant, Texto2 As Variant, x As Integer, Veces As Integer If Cadena1 = "" Or Cadena2 = "" Then Exit Function '-- Cadena1 = Homogeneizar(LCase(Cadena1)) Cadena2 = Homogeneizar(LCase(Cadena2)) '-- Texto1 = Split(Cadena1) Texto2 = Split(Cadena2) Total = UBound(Texto1) + 1 If UBound(Texto2) > UBound(Texto1) Then Total = UBound(Texto2) + 1 '-- For x = 0 To UBound(Texto1) If UBound(Filter(Texto2, Texto1(x))) > -1 Then Veces = Veces + 1 End If Next Similitud_Porcentual = Round(Veces * 100 / Total, 0) End Function Function Homogeneizar(Cadena As String) As String Homogeneizar = Replace(Cadena, "á", "a") Homogeneizar = Replace(Homogeneizar, "é", "e") Homogeneizar = Replace(Homogeneizar, "í", "i") Homogeneizar = Replace(Homogeneizar, "ó", "o") Homogeneizar = Replace(Homogeneizar, "ú", "u") Homogeneizar = Replace(Homogeneizar, "ü", "u") End Function

Otra versión mas: Public Sub Elegir_Palabra_III() Sheets("Juego").Range("C7") = "" For Each Fila In Sheets("Palabras").Range("B2").CurrentRegion.Rows If Sheets("Palabras").Range("D" & Fila.Row) = 1 Then Sheets("Juego").Range("C7") = Sheets("Palabras").Range("B" & Fila.Row) Exit For End If Next End Sub

Hoy no voy a poder, a ver si mañana puedo. 🙂

Ya que lo tenía hecho, lo subo por si te sirve de algo. La misma macro de 2 formas distintas. Public Sub Elegir_Palabra() Hoja2.Range("C7") = "" For x = 2 To Hoja1.Range("B" & Rows.Count).End(xlUp).Row 'Última fila If Hoja1.Range("D" & x) = 1 Then Hoja2.Range("C7") = Hoja1.Range("B" & x) Exit For End If Next End Sub Public Sub Elegir_Palabra_II() Sheets("Juego").Range("C7") = "" For x = 2 To Sheets("Palabras").Range("B" & Rows.Count).End(xlUp).Row 'Última fila If Sheets("Palabras").Range("D" & x) = 1 Then Sheets("Juego").Range("C7") = Sheets("Palabras").Range("B" & x) Exit For End If Next End Sub

Creo que tengo algo parecido a lo que buscas, más tarde o mañana lo miro. ¡FORZA ITALIA! .

Sin el archivo es muy complicado averiguar el porqué de tu problema.

Sin archivo no hay nada que hacer.

¿Estás seguro que tu hoja se llama Hoja y no Hoja1 o Hoja2 o cualquier otro nombre? Y otra cosa, si el nombre de la hoja contiene espacios debe ir encerrado ente comillas simples.

Así también valdría: ... ListBox1.List(a, 6) = Sheets("bd").Cells(fila, 10).Text ListBox1.List(a, 7) = Sheets("bd").Cells(fila, 13).Text ListBox1.List(a, 8) = Sheets("bd").Cells(fila, 14).Text ListBox1.List(a, 9) = Sheets("bd").Cells(fila, 15).Text ...

Ni idea de la existencia de Filter(), por si alguien quiere profundizar: Using Filter function

If hoja.Name <> "GS" And <> "Macros" Then

Pensaba que ya habíamos terminado con el tema de cerrar las consultas de esta manera. 😒😒