https://www.herber.de/bbs/user/33788.txt
Zum Testen bitte unbedingt in .rtf umbenennen, ist nur wegen dm Hochladen .txt.
Um diese rtf-Datei (aus Word) in Excel gelistet aufzulisten erstellte ich mir mit Hilfe von hier die nachfolgenden Codes. An sich funktionieren sie, aber bei einigen wenigen Zeilen in der rtf-Datei versagen sie und trennen die Zeile falsch auf. Ich dachte erst es läge am Split, deshalb die Variante mit der eigenen Splitfunktion, aber Ergebnis bleibt leider identisch.
aus:
Gerlach, Marcus, Berlin, *03.03.1975, Einlage: 51.129,19 EUR
Gerst, Joachim Peter, München, Einlage: 20.000,00 DEM
Gerstner, Gerald, Harthausen, "02.08.1953, Einlage: ! 25.564,59 EUR
Gesellschaft bürgerlichen Rechts Jens und Jörg Pallentin, bestehend aus a) Jens Pallentin,*10.04.1962, Buxtehude und
b) Jörg Pallentin,*11.09.1964, Buxtehude, Einlage: 51.129,19 EUR
Gießler, Beate Anna, Lingen, Einlage: 30.000,00 DEM
Gillmeier, Maria, ! Pilsting, Einlage: 100.000,00 DEM
wird in Excel:
A B C D E F G
40 Gerlach Marcus Berlin 03.03.1975 51129,19 EUR
41 Gerst Joachim Peter München 20000 DM
42 Gerstner 25564,59 EUR
43 b) Jörg Pallentin 11.09.1964 51129,19 EUR
44 Gießler Beate Anna Lingen 30000 DM
45 Gillmeier Maria ! Pilsting 100000 DM
Hier ist die datei: https://www.herber.de/bbs/user/33789.xls
Danke ^ Gruß
Reinhard
Option Explicit
Dim Satz3()
' Die Bibliothek "Microsoft Word x.x Object Library"
' muss aktiviert sein (EARLY BINDING)
Sub ImportFromWord1()
Dim WordApp As New Word.Application, strPath As String, wks1 As Worksheet
Dim strFile As String, zei, s, s2, s3, n, kurz
strFile = Worksheets("Tabelle2").Range("B1") 'cape race.rtf
Set wks1 = ThisWorkbook.Worksheets("Tabelle1")
wks1.UsedRange.Clear
strPath = Worksheets("Tabelle2").Range("A1") 'c:\Andre
With WordApp
.ChangeFileOpenDirectory strPath
.Documents.Open strFile
With .Selection
.WholeStory
.Copy
End With
wks1.Range("A1").Select
wks1.Paste
wks1.Range("A1").Select
.ActiveDocument.Close SaveChanges:=False
.Quit
End With
For zei = ActiveSheet.Range("A65536").End(xlUp).Row To 1 Step -1
Cells(zei, 1).HorizontalAlignment = xlCenter
Cells(zei, 1).HorizontalAlignment = xlLeft
If InStr(Cells(zei, 1), "Einlage") <= 0 Then
Cells(zei, 1).EntireRow.Delete
Else
s = Split(Cells(zei, 1), "Einlage:")
s2 = Split(s(0), "*")
If UBound(s2) > 0 Then Cells(zei, 5) = Left(s2(1), 10)
If InStrRev(s2(0), ",") >= Len(s2(0)) - 2 Then s2(0) = Left(s2(0), InStrRev(s2(0), ",") - 1)
s3 = Split(s2(0), ",")
Cells(zei, 1) = ""
For n = 1 To 2
If InStr(s3(0), "Dr.") > 0 And InStr(s3(0), "Dr.") < 6 Then
If Cells(zei, 1) <> "" Then Cells(zei, 1) = Cells(zei, 1) & " "
Cells(zei, 1) = Cells(zei, 1) & "Dr."
s3(0) = Mid(s3(0), InStr(s3(0), "Dr.") + 4)
End If
Next n
Cells(zei, 2) = s3(0)
If UBound(s3) = 2 Then
Cells(zei, 3) = s3(1)
Cells(zei, 4) = s3(2)
End If
If UBound(s3) = 1 Then Cells(zei, 4) = s3(1)
'Cells(zei, 3) = s3(UBound(s3))
If UBound(s) = 1 And InStr(s(1), ",") > 0 Then
s2 = Split(s(1), ",")
kurz = ""
For n = 1 To Len(s2(0))
If Mid(s2(0), n, 1) >= "0" And Mid(s2(0), n, 1) <= "9" Then kurz = kurz & Mid(s2(0), n, 1)
Next n
Cells(zei, 6) = CLng(kurz) + Left(s2(1), 2) / 100
Cells(zei, 7) = Right(s2(1), 3)
If InStr(Cells(zei, 7), "DEM") > 0 Then Cells(zei, 7) = "DM"
End If
End If
Next zei
zei = ActiveSheet.Range("A65536").End(xlUp).Row
Range("f1:f" & zei).NumberFormat = "#,##0.00"
Columns("A:G").AutoFit
Fehler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub ImportFromWord2()
Dim WordApp As New Word.Application, strPath As String, wks1 As Worksheet, Satz4
Dim strFile As String, zei, s, n, kurz
strFile = Worksheets("Tabelle2").Range("B1") 'cape race.rtf
Set wks1 = ThisWorkbook.Worksheets("Tabelle1")
wks1.UsedRange.Clear
strPath = Worksheets("Tabelle2").Range("A1") 'c:\Andre
With WordApp
.ChangeFileOpenDirectory strPath
.Documents.Open strFile
With .Selection
.WholeStory
.Copy
End With
wks1.Range("A1").Select
wks1.Paste
wks1.Range("A1").Select
.ActiveDocument.Close SaveChanges:=False
.Quit
End With
For zei = ActiveSheet.Range("A65536").End(xlUp).Row To 1 Step -1
Cells(zei, 1).HorizontalAlignment = xlCenter 'ohne diese beiden befehel steht der Text nach rechts verschoben in der Zelle!?
Cells(zei, 1).HorizontalAlignment = xlLeft
If InStr(Cells(zei, 1), "Einlage") <= 0 Then
Cells(zei, 1).EntireRow.Delete 'keine Einlage wird gelöscht
Else
Call Split2(Cells(zei, 1), "Einlage:")
s = Satz3 'Speichern für später
Call Split2(Satz3(0), "*") '* bedeutet es gibt ein Geburtsdatum
If UBound(Satz3) > 0 Then Cells(zei, 5) = Left(Satz3(1), 10) 'Geburtsdatum in E
'Entfernen von Kommas am Ende
If InStrRev(Satz3(0), ",") >= Len(Satz3(0)) - 2 Then Satz3(0) = Left(Satz3(0), InStrRev(Satz3(0), ",") - 1)
Satz4 = Satz3
Call Split2(Satz4(0), ",") 'Auftrennen nach Kommas
Cells(zei, 1) = ""
For n = 1 To 2 'Dr. bzw Dr.Dr. in A und Dr. aus Satz3(x) entfernen
If InStr(Satz3(0), "Dr.") > 0 And InStr(Satz3(0), "Dr.") < 6 Then
If Cells(zei, 1) <> "" Then Cells(zei, 1) = Cells(zei, 1) & " "
Cells(zei, 1) = Cells(zei, 1) & "Dr."
Satz3(0) = Mid(Satz3(0), InStr(Satz3(0), "Dr.") + 4)
End If
Next n
Cells(zei, 2) = Satz3(0)
If UBound(Satz3) = 2 Then 'Es gibt Name,Vorname,Stadt
Cells(zei, 3) = Satz3(1)
Cells(zei, 4) = Satz3(2)
End If
If UBound(Satz3) = 1 Then Cells(zei, 4) = Satz3(1) 'es gibt Firma,Stadt
If UBound(s) = 1 And InStr(s(1), ",") > 0 Then
'in s wurde anfangs alles gespeichert was nach "Einlage" steht, alos Euro,Cent,EUR bzw DM,Pfg,DEM
Call Split2(s(1), ",")
kurz = ""
For n = 1 To Len(Satz3(0)) 'Entfernen von Sonderzeichen aus dem Betrag
If Mid(Satz3(0), n, 1) >= "0" And Mid(Satz3(0), n, 1) <= "9" Then kurz = kurz & Mid(Satz3(0), n, 1)
Next n
Cells(zei, 6) = CLng(kurz) + Left(Satz3(1), 2) / 100 'Betrag in F
Cells(zei, 7) = Right(Satz3(1), 3) 'Währung in G
If InStr(Cells(zei, 7), "DEM") > 0 Then Cells(zei, 7) = "DM"
End If
End If
Next zei
zei = ActiveSheet.Range("A65536").End(xlUp).Row
Range("f1:f" & zei).NumberFormat = "#,##0.00"
Columns("A:G").AutoFit
Fehler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub Split2(ByVal Satz As String, ByVal Trenner As String)
Dim anz
'anz = 0
While InStr(Satz, Trenner) > 0
ReDim Preserve Satz3(anz)
Satz3(anz) = Left(Satz, InStr(Satz, Trenner) - 1)
Satz = Mid(Satz, InStr(Satz, Trenner) + Len(Trenner))
anz = anz + 1
Wend
ReDim Preserve Satz3(anz)
Satz3(anz) = Satz
End Sub