Tabeller i rtf format til csv fil

Via VBA skulel det nok være muligt

Hvis du er interesseret skal du være velkommen til at sende et uddrag af rtf-filen og en skitse af den ønskede csv-fil.
Mailadresse under min profil.

Til orientering: Har programmeret en første udgave på basis af det beskrevne samt "billedet"...

hej supertekst

beklager den sene tilbagemelding.. men der er travlt på jobbet.

det lyder super og jeg har uploaded et eksempel på det dokument som jeg har problemer med.

http://www.menneskebarn.com/download/doc.RTF

på forhånd tak

Hej tisbris

Det er ok. Jeg ser på det. Er det noget tilbagevendende - eller en engangsforestilling?

Hvis du sender en mail - så returnerer jeg filen, hvis det lykkes.


Har downloaded filen.

1. prøvekørsel er udført - csv-fil dannet på basis af de 220 tabeller

filen er en test fil, men jeg ender med at få en tilsvarende fil og denne skal blot genereres enkelt gang, så skulle jeg have dataerne... så det er ikke noget som skal automatiseres på nogen måde, blot man kan køre det manuelt.

mail er fremsendt...

Ok - filerne fremsendes .csv / .txt - kommentarer modtages gerne.

tak for filerne...

det lader dog til at csv filen ikke er helt korrekt, da 'USER Adress' læses som en formel præsenteres derfor som #NAVN? - eks. =+B_015=G22-BT1 bør konverteres til '=+B_015=G22-BT1.

derudover så passer kolonne overskrifterne ikke igennem alle felterne, grundet forskelligeheden i tabellerene i RTF-filen, hvilket betyder at man nok bør genere en csv fil pr. 'gruppe' af tabeller.

men ellers ser det rigtig godt ud :o)

Selv tak

Er godt klar over #Navn-tilfældet derfor også i .txt-format.

Intet problem at sætte ' foran.

Ser på problemet vedr. overskrifter.

Rem VERSION 2
Rem =========
Public Sub konverterTilCsv()
Const startTabelNr = 1

Dim xSti As String
Dim antalTabeller As Integer, tabel As Integer
Dim overSkrifter As String, overskrifterPT As String, csvData As String
    xSti = hentSti
   
    antalTabeller = ActiveDocument.Tables.Count
    overSkrifter = ""
    csvData = ""
   
    Open xSti + "KonvFil_" & CStr(startTabelNr) & ".csv" For Output As #1
   
    If antalTabeller > 0 Then
        For tabel = 1 To antalTabeller

            If tabel = 1 Then
                overSkrifter = hentOverskrifter(tabel)
                overskrifterPT = overSkrifter
                Print #1, overSkrifter
            Else
                overSkrifter = hentOverskrifter(tabel)
                If sammenlignOverskrifter(overSkrifter, overskrifterPT) = False Then
                    overskrifterPT = overSkrifter
                   
                    Close #1
                    Open xSti + "KonvFil_" & CStr(tabel) & ".csv" For Output As #1
                    Print #1, overSkrifter
                   
                End If
            End If
           
            csvData = hentData(tabel)
            Print #1, csvData
        Next tabel
    End If
   
    Close #1
   
    MsgBox ("Konvertering afsluttet")
End Sub
Private Function hentSti()
    hentSti = ActiveDocument.Path
    If Right(hentSti, 1) <> "\" Then
        hentSti = hentSti + "\"
    End If
End Function
Private Function sammenlignOverskrifter(tekstNu, tekstPT)
Dim f As Integer, tegnPT As String, tegnNu As String, p
    t1 = tekstNu
    t2 = tekstPT
   
    overskriftNu = afskærTekst(t1)
    overskriftPT = afskærTekst(t2)

    For f = 1 To Len(overskriftPT)
        tegnPT = Mid(overskriftPT, f, 1)
        tegnNu = Mid(overskriftNu, f, 1)
        If tegnPT <> tegnNu Then
            sammenlignOverskrifter = False
            Exit Function
        End If
       
        sammenlignOverskrifter = True
    Next f
End Function
Private Function afskærTekst(tekst)
Dim p
    p = InStr(tekst, "Hide Point")
    If p > 0 Then
        tekst = Left(tekst, p - 1)
    End If
    afskærTekst = tekst
End Function
Private Function hentOverskrifter(tabelNr)
Dim overskrift As String, del As String
Dim antalRækker As Byte, kolonPos As Byte
Dim tabel As Table, celle As Cell, række As Byte, område As Range

    overskrift = ""
    Set tabel = ActiveDocument.Tables(tabelNr)
    antalRækker = tabel.Rows.Count
   
    For række = 1 To antalRækker
        For Each celle In tabel.Rows(række).Cells
            Set område = celle.Range
            del = område.Text
           
            del = fjernTabelTegn(del)
           
            kolonPos = InStr(del, ":")
            If Len(del) > 2 Then
                If kolonPos > 0 Then
                    overskrift = overskrift + Trim(Left(del, kolonPos - 1)) + ";"
                Else
                    Stop
                End If
            Else
                overskrift = overskrift + ";"
            End If
        Next celle
    Next række
   
    hentOverskrifter = overskrift
End Function
Private Function hentData(tabelNr)
Dim data As String, del As String, dataDel As String
Dim antalRækker As Byte, kolonPos As Byte
Dim tabel As Table, celle As Cell, række As Byte, område As Range

    data = ""
    Set tabel = ActiveDocument.Tables(tabelNr)
    antalRækker = tabel.Rows.Count
   
    For række = 1 To antalRækker
        For Each celle In tabel.Rows(række).Cells
            Set område = celle.Range
            del = Left(område.Text, Len(område.Text) - 2)
           
            del = Trim(fjernTabelTegn(del))
           
            kolonPos = InStr(del, ":")
           
            If Len(del) > 2 Then
                If kolonPos > 0 Then
                    dataDel = Mid(del, kolonPos + 1)
                   
                    If InStr(dataDel, "+") = 1 And InStr(dataDel, "=") > 0 Then
                        dataDel = "'" + dataDel
                    End If
                   
                    data = data + dataDel + ";"
                Else
                    Stop
                End If
            Else
                data = data + ";"
            End If
        Next celle
    Next række
   
    hentData = data
End Function
Private Function fjernTabelTegn(del As String)      'fjerner TAB & celle-tegn
    del = Replace(del, Chr(9), "")
    del = Replace(del, Chr(13), "")
    del = Replace(del, Chr(7), "")
    fjernTabelTegn = del
End Function

det prøver jeg... endnu engang  - tak for hjælpen :o)