Ir ao conteúdo
  • Cadastre-se

Excel com celulas em formatação RTF


Posts recomendados

Tive um problema com texto em formatação RTF, exemplo do texto:

 

{\rtf1\ansi\ansicpg1252\deff0{\fonttbl{\f0\fnil\fcharset0 Arial;}}
\viewkind4\uc1\pard\lang1046\fs20 Observa\'e7\'f5es
\par 
\par OBSERVA\'c7\'d5ES
\par }

 

 

utilizei este vba para retirar apenas o texto que me interessava:

 

 
Public Function Rtf2Txt(tText As String) As String
' De reeks RtfCode(1-60) wordt gebruikt om extra rare tekens in vast te leggen welke
' bij het tonen van de tekxt uit de verschillende NOTES uit MARVAL weggehaald moeten / kunnen
' worden, deze kan aan naar gelang aangepast gewijzigd worden.
Dim x As Integer
Dim xPos As Integer, xNext As Integer, yPos As Integer
Dim ttxt As String
 
Dim RtfCode(100) As String
 
RtfCode(1) = "@@@"
RtfCode(2) = "///"
RtfCode(3) = "???"
RtfCode(4) = "'''"
RtfCode(5) = "***"
RtfCode(6) = "---"
RtfCode(7) = "==="
RtfCode(8) = ">>>"
RtfCode(9) = "\tab "
RtfCode(10) = "\par }"
RtfCode(11) = ""
RtfCode(12) = "-=- "
RtfCode(13) = ";;;"
RtfCode(14) = "\b0"
RtfCode(15) = "\cf2"
RtfCode(16) = "\f1"
RtfCode(17) = "\fs24"
RtfCode(18) = "\fx"
RtfCode(19) = "\pard"
RtfCode(20) = "\fs20"
RtfCode(21) = "\f0"
RtfCode(22) = "\f1"
RtfCode(23) = "\cf1"
RtfCode(24) = "\f3"
RtfCode(25) = "\protect0"
RtfCode(26) = "\protect"
RtfCode(27) = "\sa96"
RtfCode(28) = "cf0"
RtfCode(29) = "\tab"
RtfCode(30) = "\fi"
RtfCode(31) = "\~"
RtfCode(32) = "\fnil"
RtfCode(33) = "\deflang1046"
RtfCode(34) = "\fz"
RtfCode(35) = "\f4"
RtfCode(36) = "\b"
RtfCode(37) = "\sb"
RtfCode(38) = "\ulnone"
RtfCode(39) = "\ul"
RtfCode(40) = "\f2"
RtfCode(41) = "\sa100\"
RtfCode(42) = "\fs18"
RtfCode(43) = "\ri360100"
RtfCode(44) = "\li360"
RtfCode(45) = "\fs16"
RtfCode(46) = "\'bf"
RtfCode(47) = "\ltrpar96"
RtfCode(48) = "\ltrpar"
RtfCode(49) = "\fs17"
RtfCode(50) = "\kerning0"
RtfCode(51) = "\keepn"
RtfCode(52) = "\sa60"
RtfCode(53) = "\sa40"
RtfCode(54) = "\s1"
RtfCode(55) = "\qjct"
RtfCode(56) = "\qj"
RtfCode(57) = "\li720"
RtfCode(58) = "' -> '"
RtfCode(59) = "\ansicpg1252"
RtfCode(60) = "\deff0"
RtfCode(61) = "\red0"
RtfCode(62) = "\blue0"
RtfCode(63) = "\green0"
RtfCode(64) = "\uc1"
RtfCode(65) = "\viewkind4"
RtfCode(66) = "\rtf1"
RtfCode(67) = "\ansi"
RtfCode(68) = "\colortbl"
RtfCode(69) = "\fswiss\fprq2\fcharset0"
RtfCode(70) = "ttbl;"
RtfCode(71) = "blue255"
RtfCode(72) = "\fonttbl"
RtfCode(73) = ";"
RtfCode(74) = "\fcharset0"
RtfCode(75) = "\fs22 "
RtfCode(76) = "\ "
RtfCode(77) = "\fbidis\fswiss\fprq2"
RtfCode(78) = "\fswiss\fprq2"
RtfCode(79) = "\fmodern\fcharset0 Courier New"
RtfCode(80) = "\fbidis"
RtfCode(81) = "}"
RtfCode(82) = Space(2)
RtfCode(83) = "{"
RtfCode(84) = "\f2\froman\fcharset0"
RtfCode(85) = "Times New Roman"
RtfCode(86) = " Arial"
RtfCode(87) = "\fswiss\froman"
RtfCode(88) = " MS Sans Serif"
RtfCode(89) = " Verdana"
RtfCode(90) = "\fswiss"
RtfCode(91) = "\lang1046"
RtfCode(92) = ""
RtfCode(93) = ""
RtfCode(94) = ""
RtfCode(95) = ""
RtfCode(96) = ""
RtfCode(97) = ""
RtfCode(98) = ""
RtfCode(99) = ""
RtfCode(100) = ""
' Aan de hand van bovenstaande reeks worden die tekens vervangen door ""
' X = 1
For x = 1 To 100
    tText = Replace(tText, RtfCode(x), Space(0))
    ' X = X + 1
Next x  'Loop While RtfCode(X) <> "" And X < 100
 
tText = Replace(tText, Chr(13), vbNullString)
tText = Replace(tText, Chr(10), vbNullString)
 
ttxt = "#"
For xPos = 1 To Len(tText)
    If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
        tText = ReduceTxt(tText, xPos)
        Exit For
    End If
Next xPos
 
tempTxt = "HHA"
For xPos = 1 To Len(tText)
    If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
        tText = ReduceTxt(tText, xPos)
        Exit For
    End If
Next xPos
 
tempTxt = "2009"
For xPos = 1 To Len(tText)
    If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
        tText = ReduceTxt(tText, xPos)
        Exit For
    End If
Next xPos
 
tempTxt = "BO g"
For xPos = 1 To Len(tText)
    If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
        tText = ReduceTxt(tText, xPos)
        Exit For
    End If
Next xPos
 
For xPos = 1 To Len(Trim(tText))
    If Mid(tText, xPos, 1) <> " " Then
        tText = ReduceTxt(tText, xPos)
        Exit For
    End If
Next xPos
 
For xPos = Len(Trim(tText)) To 1 Step -1
    If Mid(tText, xPos, 1) <> " " Then
        tText = Left(tText, xPos)
        Exit For
    End If
Next xPos
 
x = 1
xPos = 1
xNext = 1
' Haalt bij de RTF opmaak de eerste accolade weg
tText = Replace(tText, "{", "")
 
' Er komen een serie codes voor, voorafgegaan door /tx en dan cijfers
' Deze routine zoekt de \tx op en de daarop volgende \ en verwijderd de
' reeks \tx???????
' Dit doet ie totdat er geen \tx meer voorkomt
If InStr(1, tText, "\tx") = 0 Then GoTo Doorgaan
 
Do
    xPos = InStr(xPos, tText, "\tx")
    yPos = IIf(InStr(xPos + 1, tText, "\") <= xPos, 1, -1)
    If xPos > 0 And yPos >= xPos Then tText = Replace(tText, Mid(tText, xPos, yPos), "")
Loop While InStr(1, tText, "\tx") > 0
xPos = 1
 
Doorgaan:
tText = Replace(tText, "}", "")
tText = Replace(tText, "{", "")
' hier wordt de RTF opmaak afsluit commando verwijderd \par }
tText = Replace(tText, "\par }", "")
tText = Replace(tText, "\'e7", "ç")
tText = Replace(tText, "\'c7", "Ç")
tText = Replace(tText, "\'f5", "õ")
tText = Replace(tText, "\'d5", "Õ")
tText = Replace(tText, "\'c3", "Ã")
tText = Replace(tText, "\'e3", "ã")
tText = Replace(tText, "\'ea", "ê")
tText = Replace(tText, "\'ca", "Ê")
tText = Replace(tText, "\'e1", "á")
tText = Replace(tText, "\'c1", "Á")
tText = Replace(tText, "\'e9", "é")
tText = Replace(tText, "\'c9", "É")
tText = Replace(tText, "\'e0", "à")
tText = Replace(tText, "\'c0", "À")
tText = Replace(tText, "\par ", " ")
 
 
 
Rtf2Txt = tText
 
End Function
 
Function ReduceTxt(tText As String, xPos As Integer) As String
    ReduceTxt = Right(tText, Len(tText) - (xPos - 1))
End Function
 
 
 
O resultado foi:
Observações OBSERVAÇÕES
 
 
Espero que seja util.
Link para o comentário
Compartilhar em outros sites

Visitante
Este tópico está impedido de receber novas respostas.

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...