Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1432to1436
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Ausgewählte Zellen aus Word in Excel einlesen

Ausgewählte Zellen aus Word in Excel einlesen
30.06.2015 16:29:11
Hornung
Hallo zusammen,
ich möchte gerne ausgewählte Zellen aus Word in Excel einlesen lassen. Hierfür habe ich über die Suche hier im Forum bereits folgenden Code gefunden:
http://vbanet.blogspot.de/2012/10/word-tabelle-durchsuchen-zelleninhalt.html

Option Explicit
' Suchbegriff bei Bedarf anpassen
Const strSearchTMP As String = "Genehmigt"
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module : Module2
' Procedure : Main_1
' Author : Case (Ralf Stolzenburg)
' Date : 05.10.2012
' Purpose : Word - Tabelle - Zelle auslesen...
'--------------------------------------------------------------------------
Public Sub Main_1()
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim objSearch As Object
Dim intCount As Integer
Dim lngLastRow As Long
Dim objTable As Object
Dim strPfad As String
Dim objCell As Object
Dim strTMP As String
Dim objApp As Object
Dim lngTMP As Long
On Error GoTo Fin
' Pfad anpassen für festen Pfad
'strPfad = "C:\Temp\"
' Tabellenblattname anpassen
Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
' Dateien sind im gleichen Ordner wie Exceldatei
strPfad = ThisWorkbook.Path & Application.PathSeparator
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With wksSheet
.Columns(3).Clear
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 2)), _
.Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
End With
For lngTMP = 1 To lngLastRow
' Wenn OHNE Endung ".doc" in Spalte B, dann diese Zeile
'strDatei = Dir$(strPfad & .Cells(lngTMP, 2).Value & ".doc*")
' Wenn MIT Endung ".doc" in Spalte B, dann diese Zeile
If Dir$(strPfad & wksSheet.Cells(lngTMP, 2).Value)  "" Then
Set objDocument = objApp.Documents.Open _
(strPfad & wksSheet.Cells(lngTMP, 2).Value)
If objDocument.Tables.Count >= 1 Then
Set objTable = objDocument.Tables(1)
For Each objSearch In objTable.Range.Cells
If InStr(objSearch.Range.Text, strSearchTMP) > 0 Then
Set objCell = objSearch.Range.Cells(1).Next.Range
End If
Next objSearch
For intCount = 1 To objCell.Words.Count - 1
strTMP = strTMP & objCell.Words.Item(intCount).Text
Next intCount
wksSheet.Cells(lngTMP, 3).Value = strTMP
Else
wksSheet.Cells(lngTMP, 3).Value = "No table available"
End If
Set objCell = Nothing
objDocument.Close False
Else
wksSheet.Cells(lngTMP, 3).Value = "No file"
End If
strTMP = ""
Next lngTMP
Else
MsgBox "Application not installed!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objCell = Nothing
Set objTable = Nothing
Set objDocument = Nothing
Set objApp = Nothing
Set wksSheet = Nothing
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function


Jetzt bräuchte ich diesen Code etwas angepasst. Und zwar habe ich jeweils nur ein Word-Doc. (anstatt mehrere), das wiederum den entsprechenden zu findenden Wert mehrmals enthält.
D.h.
bisheriger Code: eine Tabelle vorgesehen; durchsucht ganzes Dokument, findet Zelle mit Suchkriterium und gibt Zellenwert rechts daneben wieder
Wunschcode: mehrere Tabellen vorhanden; durchsucht ganzes Dokument, findet alle Zellen mit Suchkriterium und gibt jeweils den Zellenwert rechts daneben wieder.
Kann mir hierbei jemand helfen? Das wäre super!
Vielen Dank im Voraus
Viele Grüße
Marcel

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Das dürfte...
01.07.2015 08:01:57
Case
Hallo, :-)
... so der Spur nach gehen. Das "If objDocument.Tables.Count >= 1 Then" brauchst Du eventuell nicht. Musst halt noch etwas anpassen - sollte aber grundsätzlich funzen.
Option Explicit
' Suchbegriff bei Bedarf anpassen
Const strSearchTMP As String = "Genehmigt"
Dim blnTMP As Boolean
' Module    : Module2
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 05.10.2012
' Purpose   : Word - Tabelle - Zelle auslesen...
Public Sub Main_1()
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim objSearch As Object
Dim intCount As Integer
Dim lngLastRow As Long
Dim objTable As Object
Dim strPfad As String
Dim objCell As Object
Dim strTMP As String
Dim objApp As Object
Dim lngTMP As Long
On Error GoTo Fin
' Pfad anpassen für festen Pfad
'strPfad = "C:\Temp\"
' Tabellenblattname anpassen
Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
' Dateien sind im gleichen Ordner wie Exceldatei
strPfad = ThisWorkbook.Path & Application.PathSeparator & "Test1.doc"
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With wksSheet
.Columns(3).Clear
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 2)), _
.Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
End With
If Dir$(strPfad)  "" Then
Set objDocument = objApp.Documents.Open _
(strPfad)
For lngTMP = 1 To objDocument.Tables.Count
If objDocument.Tables.Count >= 1 Then
Set objTable = objDocument.Tables(lngTMP)
For Each objSearch In objTable.Range.Cells
If InStr(objSearch.Range.Text, strSearchTMP) > 0 Then
Set objCell = objSearch.Range.Cells(1).Next.Range
End If
Next objSearch
For intCount = 1 To objCell.Words.Count - 1
strTMP = strTMP & objCell.Words.Item(intCount).Text
Next intCount
wksSheet.Cells(lngTMP, 3).Value = strTMP
Else
wksSheet.Cells(lngTMP, 3).Value = "No table available"
End If
Set objCell = Nothing
strTMP = ""
Next lngTMP
End If
Else
MsgBox "Application not installed!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objCell = Nothing
Set objTable = Nothing
Set objDocument = Nothing
Set objApp = Nothing
Set wksSheet = Nothing
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function
Servus
Case

Anzeige
AW: Das dürfte...
01.07.2015 10:24:58
Hornung
Zuerst einmal vielen Dank!
Leider klappt es noch nicht ganz, er findet nicht alle Werte
bspw.
Tabelle 1
1 test 2
3 test 3
5 test 5
Tabelle 2
2 34 4
Test Test 12
2 5 7
Dann gibt er mir aus:
5, 12
Richtig wäre jedoch:
2, 3, 5, Test, 12
Ich habe noch ein bisschen rumprobiert und es scheint als würde er immer nur 2 ausgeben.
Leider weiß ich mir damit nicht zu helfen :/
(Noch als kleines mögliches zusätzliches Problem, falls das einen Unterschied machen sollte: in meiner eigentlichen Worddatei wird es so sein, dass im Dokument die Formatierung so ist, dass links mehrere Zellen zusammengefasst sind, dort der "Suchwert" mehrmals steht und rechts daneben sich dann in einzelnen Zellen die auszugebenden Werte befinden. An der (ungünstigen) Formatierung kann man leider nichts ändern)
Zufällig noch eine Idee? :)
Viele Grüße
Marcel

Anzeige
Da habe ich noch...
01.07.2015 10:48:13
Case
Hallo, :-)
... einige Ideen. Bevor das aber zu einer unendlichen Geschichte wird, solltest Du mal eine Worddatei mit der originalen Formatierung und anonymisierten Daten hochladen.
Dann "schau mer mol"...
Servus
Case

AW: Da habe ich noch...
04.07.2015 11:06:46
Hornung
Hallo,
hier die Datei:
https://www.herber.de/bbs/user/98630.doc
Als Ergebnistabelle ist der Wunsch, dass die jeweilige Überschrift zur Tabelle angezeigt wird und dazu "Gerätx" und (optimalerweise noch die Möglichkeit bei Wunsch "Infox" anzeigen zu lassen):
Ergebnistabelle für FZ-8
Variante1
Gerät3 (Info3)
Gerät4 (Info4)
Gerät5 (Info5)
Variante 2
Gerät4 (Info4)
Variante 3
Gerät3 (Info3)
Gerät4 (Info4)
Gerät5 (Info5)
Gerät7 (Info6)
Gerät8 (Info7)
Gerät9 (Info8)
etc.
Ich hoffe das ist verständlich und danke schon einmal! :)
VG Marcel

Anzeige
AW: Da habe ich noch...
07.07.2015 17:57:27
Hornung
Und denkst du das könnte klappen?

8 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige