Dim DadosExternos(2, 100) As String ' nome arquivo - conteudo arquivo
Function ContaPalavra(textoprocurado, NoTexto)
  If textoprocurado = "" Then
     ContaPalavra = 0
     Exit Function
  End If
  i = InStr(1, NoTexto, textoprocurado, vbTextCompare)
  If i = 0 Then
     ContaPalavra = 0
  Else
    qtd = 0
    Do
       qtd = qtd + 1
       i = InStr(i + 1, NoTexto, textoprocurado, vbTextCompare)
    Loop Until i = 0 Or i > Len(NoTexto)
    ContaPalavra = qtd
  End If
End Function
Function som(Texto)
   Dim i, orig, dest, trab, resp, ultimo, este
   Static conv(255)
   If conv(1) <> " " Then   ' só faz a primeira vez
      orig = "AÁÀÃÂEÉÈÊ&IÍÌÎOÓÕÔUÚÙÛÜBCÇDFGHJKLMNPQRSTUVWXÿYZÑ0123456789,."
      dest = "AAAAAIIIIEIIIIUUUUUUUUUB@@DF#H#@LMNPQR@TUUU@II@N0123456789,."
      For i = 1 To 255
          conv(i) = " "
      Next
      For i = 1 To Len(orig)
          conv(Asc(Mid(orig, i, 1))) = Mid(dest, i, 1)
      Next
   End If
   trab = UCase(Texto) & " "
   resp = ""
   For i = 1 To Len(trab) - 1
      este = conv(Asc(Mid(trab, i, 1)))
      If (este <> " " And ultimo <> este) Or IsNumeric(este) Then ' ignora letras dobradas e espaços
         ultimo = este
         resp = resp & ultimo
      End If
   Next
   som = resp
End Function
Function ContaSom(textoprocurado, NoTexto)
  ContaSom = ContaPalavra(som(textoprocurado), som(NoTexto))
End Function
Function trocar(Texto, ParamArray lista())
    x = Texto
    For i = 0 To UBound(lista) Step 2
        x = Replace(x, lista(i), lista(i + 1))
    Next
    trocar = x
End Function
Function AllTrim(x)
 z = Trim(x)
 Do While InStr(1, z, "  ") > 0   ' loop enquanto tem brancos dobrados
   z = Replace(z, "  ", " ")
 Loop
 AllTrim = z
End Function
Function Palavra(Frase, ordem)
   novafrase = trocar(Frase, ".", " ", ",", " ", "(", " ", ")", " ", ":", " ", ";", " ")
   novafrase = AllTrim(novafrase)
   palavras = Split(novafrase, " ")
   If ordem > UBound(palavras) + 1 Then
      Palavra = palavras(UBound(palavras))
   Else
      Palavra = palavras(ordem - 1)
   End If
End Function
Function ValorAposTexto(textoprocurado, NoTexto)
     arg = UCase(Trim(textoprocurado))
     i = InStr(1, UCase(NoTexto), arg)
     If i = 0 Then
        ValorAposTexto = ""
        Exit Function
     End If
     For i = i + Len(arg) To Len(NoTexto)
         If IsNumeric(Mid(NoTexto, i, 1)) Then
            Exit For
         End If
     Next
     If i > Len(NoTexto) Then
        ValorAposTexto = ""
        Exit Function
     End If
     inic = i
     valor = Mid(NoTexto, i, 1)
     Do
        i = i + 1
        valorok = valor
        valor = valorok & Mid(NoTexto & "*", i, 1)
     Loop While IsNumeric(valor)
     ValorAposTexto = CDbl(valorok)
End Function
Function PegaValorNoArquivo(textoprocurado, filename)
    i = 1
    arq = UCase(filename)
    Do While DadosExternos(1, i) <> "" And arq <> DadosExternos(1, i)
        i = i + 1
    Loop
    If DadosExternos(1, i) = "" Then   ' ainda não leu o arquivo
       DadosExternos(1, i) = arq
       On Error Resume Next
       Open ActiveWorkbook.Path & "\" & arq For Input As #1
       If Err.Number <> 0 Then
            DadosExternos(2, i) = ""
       Else
            On Error GoTo 0         ' para de mascarar erros de programação
            conteudo = ""
            While Not EOF(1)
               Line Input #1, linha
               conteudo = conteudo & " " & linha
            Wend
            DadosExternos(2, i) = som(conteudo)
       End If
       Close #1
    End If
 '  aqui estamos com os dados lidos
    PegaValorNoArquivo = ValorAposTexto(som(textoprocurado), DadosExternos(2, i))
End Function