AW: Text aus .doc in Exel kopieren
17.01.2007 10:43:17
fcs
Hallo niru,
das folgende Makro holt aus der aktiven Worddatei den Text, fügt ihn ins aktive Excelblatt ein und splittet den Text.
Füge das Makro in ein Modul in einer neuen/leeren Exceldatei ein.
Damit das Makro korrekt funktioniert muss du im VBA-Editor unter Menü Extras--Verweise die "Microsoft Word x.yz Object Library" als verfügbar markieren.
Wichtig vor dem Start des Excel-Makros:
1. in Word die Datei öffnen
2. nach Excel wechseln und ein leeres Tabellenblatt wählen
Gruß
Franz
Sub Text_aus_Worddatei_splitten()
' Kopiert den gesamt Text aus dem aktiven Worddokument ins Tabellenblatt und trennt die Texte
' Für korrekte Funktion im VBA- Editor unter Extras-->Verweise _
Microsoft Word x.yz Object Library als verfügbar markieren
' Textmuster: [192.16.1.133]00b0008d3561 WNTBERLIN
Dim wks As Worksheet, dokument As Document
Set wks = ActiveSheet
'Word text kopieren
Application.ActivateMicrosoftApp (xlMicrosoftWord)
Set dokument = ActiveDocument
dokument.StoryRanges(wdMainTextStory).Copy
Word.Application.WindowState = wdWindowStateMinimize
With wks
.Range("A1").Select
.Paste
' Text am Zeichen "]" trennen und in Spalten B und C einfügen
.Columns("A:A").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="]", FieldInfo:=Array(Array(1, 2), Array(2, 2))
' Text in Spalte C am Leerzeichen trennen und in Spalten C und D einfügen
.Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=" ", FieldInfo:=Array(Array(1, 2), Array(2, 2))
'Zeichen "[" in Spalte B durch Leerstring ersetzen.
.Columns("B:B").Replace What:="[", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Columns.EntireColumn.AutoFit
.Range("A1").Select
End With
End Sub