Segregar o título em palavras e pesquisá-lo em outro título

Question

Eu estava tentando automatizar um arquivo do Excel que tem título em ambas as colunas A e B e eu tenho que pesquisar cada palavra de A dentro B. Se alguma palavra for correspondente, eu preciso colá-la depois da coluna B que está disponível (C , D, ...) na mesma linha.

Eu estava usando o código abaixo para o qual estarei segregando as palavras manualmente em uma coluna separada do título da coluna A e pesquisando-as na coluna B.

Dim a() As String
Dim b() As String
Dim aRng As Range
Dim cel As Range
Dim i As Integer, t As Integer, clm As Integer

Set aRng = Range(Range("KW1"), Range("KW1").End(xlDown))

For Each cel In aRng
    a = Split(cel, " ")
    b = Split(cel.Offset(, 1), " ")
    clm = 2

    For i = LBound(a) To UBound(a)
        For t = LBound(b) To UBound(b)
            If UCase(a(i)) = UCase(b(t)) Then
                cel.Offset(, clm) = a(i)
                clm = clm + 1
            End If
        Next
    Next

Next

mas repetindo palavras duplicadas de novo e de novo, se houver. Existe uma maneira de evitar palavras duplicadas? Por favor me ajude.

    

Answer 1

Este não é realmente o método mais limpo, mas você pode apenas verificar cada célula preenchida passando por elas a partir de um deslocamento de 2 até chegar a uma célula vazia. Note que este código não foi testado.

For i = LBound(a) To UBound(a)
    For t = LBound(b) To UBound(b)
        If UCase(a(i)) = UCase(b(t)) Then
            clm = 2
            Do While True
                If UCase(cel.Offset(, clm)) = UCase(a(i)) Then
                    Exit Do
                End If
                If cel.Offset(, clm) = "" Then
                    cel.Offset(, clm) = a(i)
                    Exit Do
                End If
                clm = clm + 1
            Loop
        End If
    Next
Next

    

Answer 2

Sub percentage()

Dim a () As String Dim b () como string Dim aRng As Range Dim cell As Range Dim i Como Integer, t Como Integer, clm As Integer Defina aRng = Range (Range ("A1"), Range ("A65536"). End (xlDown))

Para cada cel In aRng     a = Split (cel, "")     b = Dividir (cel.Offset (, 1), "")     d = 0     clm = 2     C = UBound (a) If cel.Value < > "" Então     Para i = LBound (a) Para UBound (a)

        For t = LBound(b) To UBound(b)
            If UCase(a(i)) = UCase(b(t)) Then
                clm = 2
             Do While True
                If UCase(cel.Offset(, clm)) = UCase(a(i)) Then
                Exit Do
                End If
                    If cel.Offset(, clm) = "" Then
                        'cel.Offset(, clm) = a(i)
                        Exit Do
                    End If
                    clm = clm + 1
                Loop
                d = d + 1
            End If

        Next

Next

'MsgBox "Total de palavras" & Acampamento; "Palavras correspondentes" & d 'cel.Offset (0, 2) .Value = (d / c) Fim se Próxima

End Sub '