Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Ausgewählte Zellen aus Word in Excel einlesen

Betrifft: Ausgewählte Zellen aus Word in Excel einlesen von: Hornung
Geschrieben am: 30.06.2015 16:29:11

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

  

Betrifft: Das dürfte... von: Case
Geschrieben am: 01.07.2015 08:01:57

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



  

Betrifft: AW: Das dürfte... von: Hornung
Geschrieben am: 01.07.2015 10:24:58

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


  

Betrifft: Da habe ich noch... von: Case
Geschrieben am: 01.07.2015 10:48:13

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



  

Betrifft: AW: Da habe ich noch... von: Hornung
Geschrieben am: 04.07.2015 11:06:46

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


  

Betrifft: AW: Da habe ich noch... von: Hornung
Geschrieben am: 07.07.2015 17:57:27

Und denkst du das könnte klappen?


 

Beiträge aus den Excel-Beispielen zum Thema "Ausgewählte Zellen aus Word in Excel einlesen"