Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Worddateien in Ordner auslesen
14.03.2009 19:39:18
Dirk
Hallo Excelgemeinde!
Ich brauche eure Hilfe!!!!
Ich habe folgendes Problem:
Ich muß bestimmte Daten aus allen vorhandenen Word Dokumenten in einem Verzeichnis (inkl. Unterverzeichnisse) auslesen. Ich habe bereits eine Exceldatei mit der ich eine Worddatei in einem Verzeichnis auswählen kann und Daten in Excel kopiere.
Aber leider schaffe ich es nicht automatisch diese Aktion mit allen vorhandenen Worddateien in einem Verzeichnis auszuführen.
Daher bitte ich um eure Hilfe!
Ich hoffe mir kann geholfen werden?
LG
Dirk R.

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Worddateien in Ordner auslesen
14.03.2009 20:09:42
Josef
Hallo Dirk,
zeig deinen bisherigen Code.
Gruß Sepp

AW: Worddateien in Ordner auslesen
14.03.2009 20:21:03
Dirk
Hallo Sepp!
Folgenden Code habe ich bisher gebastelt:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long

Public Sub loeschen_Zwischenablage()
OpenClipboard FindWindow("xlMain", vbNullString)
EmptyClipboard
CloseClipboard
End Sub



Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim AppWD As Object
Dim fn
Const StartDrive = "C:"
Const StartDir = "\"
ChDrive StartDrive
ChDir StartDir
fn = Application.GetOpenFilename("Word-Dokumente, *.doc", , "Bitte Datei auswählen")
If fn = False Then Exit Sub 'Abbrechen gedrückt
Set AppWD = CreateObject("Word.Application") 'Word als Object starten
With AppWD
.DisplayAlerts = False
.Visible = False
.Documents.Open fn
.Selection.Wholestory
.Selection.Copy
ThisWorkbook.Sheets("Tabelle1").Cells(1, 1).Activate
ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
loeschen_Zwischenablage
.DisplayAlerts = True
.Documents.Close
.Quit
Set AppWD = Nothing
Application.ScreenUpdating = True
End With
End Sub


Bisher kopiert der Code den Kompletten Text der ausgewählten Worddatei und fügt diesen Text in ein Tabellenblatt beginnend mit A1.
Der Code wird von mir noch so geändert, dass die Daten später ´so kopiert werden, dass die Datensätze einer Worddatei in eine Zeile geschrieben werden.
d.h.: die Daten der erten Worddatei werden dann in Zeile 1 geschrieben. Die Daten der zweiten Worddatei werden dann in Zeile 2 geschrieben usw.
Lg
Dirk R.

Anzeige
AW: Worddateien in Ordner auslesen
14.03.2009 20:51:10
Dirk
Hallo Sepp!
Ich muss leider den Rechner ausmachen.
Solltest du mir noch antworten, wäre ich dir sehr dankbar.
Ich kann leider erst morgen wieder antworten.
LG
Dirk R.
AW: Worddateien in Ordner auslesen
14.03.2009 20:52:22
Dirk
Frage noch offen
AW: Worddateien in Ordner auslesen
14.03.2009 21:56:57
Josef
Hallo Dirk,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long

Public Sub loeschen_Zwischenablage()
  OpenClipboard FindWindow("xlMain", vbNullString)
  EmptyClipboard
  CloseClipboard
End Sub

Private Sub CommandButton1_Click()
  Dim AppWD As Object
  Dim objFiles() As Object
  Dim lngR As Long, lngRes As Long, lngIndex As Long
  Dim strDirectory As String
  
  
  On Error GoTo ErrExit
  GMS
  strDirectory = fncBrowseForFolder("C:\")
  If strDirectory <> "" Then
    lngRes = FileSearchINFO(objFiles, strDirectory, "*.doc", True)
    
    If lngRes > 0 Then
      lngR = ThisWorkbook.Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row + 1
      
      Set AppWD = CreateObject("Word.Application") 'Word als Object starten
      With AppWD
        .DisplayAlerts = False
        .Visible = False
        For lngIndex = 0 To lngRes - 1
          .documents.Open CStr(objFiles(lngIndex))
          .Selection.wholestory
          .Selection.Copy
          ThisWorkbook.Sheets("Tabelle1").Cells(lngR, 1).Select
          ThisWorkbook.Sheets("Tabelle1").PasteSpecial _
            Format:="Text", Link:=False, DisplayAsIcon:=False
          loeschen_Zwischenablage
          .documents.Close
          lngR = lngR + 1
        Next
        .DisplayAlerts = True
        .Quit
      End With
    End If
  End If
  
  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (CommandButton1_Click) in Modul Modul1", _
      vbExclamation, "Fehler in Modul1 / CommandButton1_Click"
  End With
  
  GMS True
  If Not AppWD Is Nothing Then AppWD.Quit
  Set AppWD = Nothing
End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)
  
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    
  End With
  
End Sub

Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
  Dim objFlderItem As Object, objShell As Object, objFlder As Object
  
  Set objShell = CreateObject("Shell.Application")
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
  
  If objFlder Is Nothing Then GoTo ErrExit
  
  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path
  
  ErrExit:
  
  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long

  
  '# PARAMETERINFO:
  '# Files: Datenfeld zur Ausgabe der Suchergebnisse
  '# InitialPath: String der das zu durchsuchende Verzeichnis angibt
  '# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
  '# Beispiele: "*.txt" - Findet alle Textdateien
  '# "*name*" - Findet alle Dateien mit "name" im Dateinamen
  '# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
  '# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
  
  
  Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
  Dim intC As Integer, varFiles As Variant
  
  Set fobjFSO = CreateObject("Scripting.FileSystemObject")
  
  Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
  
  On Error GoTo ErrExit
  
  If InStr(1, FileName, ";") > 0 Then
    varFiles = Split(FileName, ";")
  Else
    Redim varFiles(0)
    varFiles(0) = FileName
  End If
  For Each ffsoFile In ffsoFolder.Files
    If Not ffsoFile Is Nothing Then
      For intC = 0 To UBound(varFiles)
        If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
          If IsArray(Files) Then
            Redim Preserve Files(UBound(Files) + 1)
          Else
            Redim Files(0)
          End If
          Set Files(UBound(Files)) = ffsoFile
          Exit For
        End If
      Next
    End If
  Next
  
  If SubFolders Then
    For Each ffsoSubFolder In ffsoFolder.SubFolders
      FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
    Next
  End If
  
  If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
  ErrExit:
  Set fobjFSO = Nothing
  Set ffsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
AW: Worddateien in Ordner auslesen
15.03.2009 09:58:35
Dirk
Hallo Sepp!!!!
Vielen Dank für deinen Code.
Habe ihn angepasst und getestet.
Er funktioniert prima.
Nochmals vielen, vielen Dank!!! :O)
LG
Dirk R.

321 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige