Import aus Word
24.04.2023 12:08:24
Ron
Hallo,
wer kann mir helfen und ggf. den Code optimieren.
Ich möchte den Inhalt von großen Word-Dateien einlesen und verarbeiten.
Leider ist die Verarbeitungsgeschwindigkeit nicht sehr gut.
Kann jemand Hand anlegen?
Option Explicit
Sub Datei_auswählen()
Dim Dateiname As Variant
Dim wdApp As Object
Dim wdDoc As Object
Dim filename As Variant
Dim newSheet As Worksheet
Dim cell As Range
Dim regEx As Object
Dim lastRow As Long
Dim i As Long
Dim a As Integer
Dim searchRange As Range
Dim matchPattern As String
Dim letzteZeile As Long
Dim rng As Range
Set wdApp = CreateObject("Word.Application")
...
'Ordner wählen, wo die Dateien abgelegt sind
ChDrive "C"
ChDir "C:\dokumente\Nummer\" & Range("F1") & "\dokumente\arbeitsbogen\"
'Nur Word-Dokumente anzeigen und auswählen
Dateiname = Application.GetOpenFilename("Word-Dokumente (*.docx*),*.doc*", , "Wählen Sie eine oder mehrere Word Dateien aus", , True)
'Wurde eine Datei ausgewählt?
If Not IsEmpty(Dateiname) Then
'Für jede ausgewählte Datei den folgenden Code ausführen
For a = LBound(Dateiname) To UBound(Dateiname)
'Neues Arbeitsblatt erstellen
Set newSheet = ThisWorkbook.Sheets.Add(after:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
newSheet.Name = a + 1 'Name des Arbeitsblatts auf "1", "2", "3", usw. setzen
'Word-Dokument öffnen
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Open(Dateiname(a))
'Inhalt kopieren
wdDoc.Content.Copy
'In Zelle A1 des aktuellen Arbeitsblatts einfügen
With newSheet
Range("A1").PasteSpecial Paste:=xlPasteValues
End With
'Word schließen
wdDoc.Close SaveChanges:=False
wdApp.Quit
'Objekte freigeben
Set wdDoc = Nothing
Set wdApp = Nothing
'Zeilen löschen, die die Suchwörter nicht enthalten
lastRow = newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row
Set searchRange = newSheet.Range("A1:A" & lastRow)
matchPattern = "\babc\b" _
& "|\bdef\b" _
& "|\bghi\b" _
& "|\bjkl\b" _
& "|\bmno\b" _
& "|\bjke\b" _
& "|\bpqr\b" _
& "|\bstz\b" _
& "|\buvw\b" _
& "|\bwvi\b" _
& "|\bVorname\b" _
& "|\bwww\b" _
& "|\bxxx\b"
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = matchPattern
regEx.Global = True
For i = lastRow To 1 Step -1
Set cell = searchRange.Cells(i, 1)
If Not regEx.Test(cell.Value) Then
cell.EntireRow.Delete
End If
Next i
'Leerzeichen aus Splate "A" vor den Wörtern entfernen
'finde die letzte Zeile mit Inhalt in Spalte B
letzteZeile = Cells(Rows.Count, "B").End(xlUp).Row
'Den Bereich auswählen und markieren
Range("A1:A" & letzteZeile).Select
Set rng = Selection
For Each cell In rng 'Schleife durch alle ausgewählten Zellen
'Ersetzen Sie alle Leerzeichen in der Zelle durch nichts
cell.Value = Replace(cell.Value, " ", "")
'Entfernen Sie alle verbleibenden Leerzeichen am Anfang und Ende der Zelle
cell.Value = Trim(cell.Value)
Next cell
Range("A1").Select
'finde die letzte Zeile mit Inhalt in Spalte A
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'gehe alle Zeilen von 1 bis zur letzten Zeile durch
For i = 1 To lastRow
'wenn der Wert in Spalte A ist
If Range("A" & i).Value = "def" Or _
Range("A" & i).Value = "ghi" Or _
Range("A" & i).Value = "mno" Then
'konvertiere den Wert in Spalte B zu einem Datum
Range("B" & i).Value = DateValue(Range("B" & i).Value)
Range("B" & i).NumberFormat = "dd.mm.yyyy"
End If
Next i
'gehe alle Zeilen von 1 bis zur letzten Zeile durch
For i = 1 To lastRow
'wenn der Wert in Spalte A ist
If Range("A" & i).Value = "jkl" Then
'konvertiere den Wert in Spalte B zu einem vierstelligen Text um
Range("B" & i).Value = Format(Range("B" & i).Value, "0000")
Range("B" & i).NumberFormat = "0000"
End If
Next i
'füge hinter jedem Wort "abc" "mno" ein, wenn nicht schon vorhanden
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = lastRow To 1 Step -1
If Range("A" & i).Value = "abc" Then
If i lastRow And Range("A" & i + 1).Value > "mno" Then
Rows(i + 1).Insert
Range("A" & i + 1).Value = "mno"
Range("B" & i + 1).Value = "---"
End If
End If
Next i
'Daten in Tabellenblatt 2 kopieren
letzteZeile = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To letzteZeile
If Range("A" & i).Value = "abc" Then
Tabelle2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "def" Then
Tabelle2.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "mno" Then
Tabelle2.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "ghi" Then
Tabelle2.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "pqr" Then
Tabelle2.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "wvi" Or Range("A" & i).Value = "www" Then
Tabelle2.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "stz" Then
Tabelle2.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "uvw" Then
Tabelle2.Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "jkl" Then
Tabelle2.Range("I" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
If Range("A" & i).Value = "xxx" Then
Tabelle2.Range("J" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("B" & i).Value
End If
Next i
'Arbeitsblatt ohne speichern schließen
Application.DisplayAlerts = False
newSheet.Delete
Application.DisplayAlerts = True
Next a
End If
...
End SubDanke