Bestehendes Makro um Funktionen erweitern

Hallo zusammen,
mit sehr viel Hilfe arbeite ich momentan mit folgendem "Programm" für Excel:
Option Explicit


Sub Daten_holen()
Dim AppWd As Object, DocWd As Object, WordDateiPfad As String, aktZeile As Integer
Dim WordDatei As String, TextWD As String
'der Pfad in dem die Word Dateien liegen, muss mit "\" enden
WordDateiPfad = "C:\Test\"
'Startzeile in der Excel-Datei
aktZeile = 2
'Word-Object erzeugen und öffnen
Set AppWd = CreateObject("Word.Application")
'Schleife für alle Word-Dateien im Verzeichnis
WordDatei = Dir(WordDateiPfad & "*.doc")
Do While WordDatei <> ""
'Datei Öffnen (unsichtbar)
AppWd.Visible = False
Set DocWd = AppWd.Documents.Open(WordDateiPfad & WordDatei)
'Erste Zeile der Word-Datei auslesen
If InStr(WordDatei, "VoI") > 0 Then
DocWd.Range(0, 0).Select
TextWD = DocWd.Bookmarks("\Line").Range.Text
'In Excel schreiben
ThisWorkbook.Worksheets(1).Range("D" & aktZeile).Value = TextWD
ThisWorkbook.Worksheets(1).Range("J" & aktZeile).Value = WordDatei
ThisWorkbook.Worksheets(1).Range("A" & aktZeile).Value = "Wettbewerberinformationen"
ThisWorkbook.Worksheets(1).Range("B" & aktZeile).Value = "Presseauswertungen"
ThisWorkbook.Worksheets(1).Range("C" & aktZeile).Value = "Newsletter VoI"
ThisWorkbook.Worksheets(1).Range("G" & aktZeile).Value = "Verband Organisations- und Informationssysteme"
ThisWorkbook.Worksheets(1).Range("H" & aktZeile).Value = "Abt. 1"
aktZeile = aktZeile + 1
End If
If InStr(WordDatei, "EbPP") > 0 Then
DocWd.Range(0, 0).Select
TextWD = DocWd.Bookmarks("\Line").Range.Text
'In Excel schreiben
ThisWorkbook.Worksheets(1).Range("D" & aktZeile).Value = TextWD
ThisWorkbook.Worksheets(1).Range("J" & aktZeile).Value = WordDatei
ThisWorkbook.Worksheets(1).Range("A" & aktZeile).Value = "Wettbewerberinformationen"
ThisWorkbook.Worksheets(1).Range("B" & aktZeile).Value = "Presseauswertungen"
ThisWorkbook.Worksheets(1).Range("C" & aktZeile).Value = "Newsletter EbPP"
ThisWorkbook.Worksheets(1).Range("G" & aktZeile).Value = "Electronic Bill Presentment and Payment"
ThisWorkbook.Worksheets(1).Range("H" & aktZeile).Value = "Abt. 1"
aktZeile = aktZeile + 1
End If
If InStr(WordDatei, "BvDP") > 0 Then
DocWd.Range(0, 0).Select
TextWD = DocWd.Bookmarks("\Line").Range.Text
'In Excel schreiben
ThisWorkbook.Worksheets(1).Range("D" & aktZeile).Value = TextWD
ThisWorkbook.Worksheets(1).Range("J" & aktZeile).Value = WordDatei
ThisWorkbook.Worksheets(1).Range("A" & aktZeile).Value = "Wettbewerberinformationen"
ThisWorkbook.Worksheets(1).Range("B" & aktZeile).Value = "Presseauswertungen"
ThisWorkbook.Worksheets(1).Range("C" & aktZeile).Value = "Newsletter BvDP"
ThisWorkbook.Worksheets(1).Range("G" & aktZeile).Value = "Bundesverband deutscher Postdienstleister e.V."
ThisWorkbook.Worksheets(1).Range("H" & aktZeile).Value = "Abt. 1"
aktZeile = aktZeile + 1
End If
'aktuelle Worddatei schließen
DocWd.Close savechanges:=False
'nächste Word Datei
WordDatei = Dir()
Loop
'Word schließen und Objekt beenden
AppWd.Quit
Set DocWd = Nothing
End Sub

-----------------------------------------------
Liest die Worddateien eines Ordners aus und schreibt je nach Dateiname die jeweiligen Informationen in ein Exceltabellenblatt. Bei Word-Dateien wird die erste Zeile der Datei ausgelesen und als Beschreibung der Datei eingefügt.
Funktioniert einwandfrei, soll aber um etwas erweitert werden:
in Spalte L soll der Dateiname stehen, aber mit der Endung .pdf! Bisher hab ich das in Excel mit der Funktion =LINKS(Jx;LÄNGE(Jx)-4) & ".pdf" gemacht, was jedoch nicht gerade die beste Lösung darstellt, da man es im Falle eines Leerens der Datei immer wieder neu eingeben müsste. Kann man diese Funktion irgendwie in VBA übertragen, so dass dies ebenfalls automatisch erledigt wird?
1) Wenn ich das ganze jetzt auch mit PDF, PPT und XLS Dateien machen will, was muss ich zu diesem Modul hinzufügen? Bei diesen 3 Dateitypen muss in Spalte D ebenfalls der Dateiname geschrieben werden, das Auslesen der ersten Zeile der Dateien fällt damit weg (macht das auch das Programmieren von so einer Methode einfacher?)
2) Bei diesen Dateien müsste dann unterschieden werden je nachdem ob sie im Dateinamen Folgendes stehen haben:
- Studie
- Vortag
- Presse Clipping
- Präsentation
Das Ziel wäre es am Ende einfach alle Word, Powerpoint, Excel und PDF-Dateien in einen Ordner reinzuschmeissen, das Makro zu starten und dann die Datei mit den Metadaten ausgegeben zu bekommen. Weiss jedoch nicht wieviel Arbeit das ganze ist.
Wenn ihr Fragen habt, dann fragt ruhig, ich werde alles beantworten was ich beantworten kann. Hoffe ihr könnt mir weiterhelfen, wäre wirklich klasse,
Vielen Dank,
Patrick

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Daten_holen() Dim AppWd As Object, DocWd As Object, WordDateiPfad As String, aktZeile As Integer Dim WordDatei As String, TextWD As String Dim twb As Worksheet Set twb = ThisWorkbook.Worksheets(1) 'der Pfad in dem die Word Dateien liegen, muss mit "\" enden WordDateiPfad = "C:\Test\" 'Startzeile in der Excel-Datei aktZeile = 2 'Word-Object erzeugen und öffnen Set AppWd = CreateObject("Word.Application") 'Schleife für alle Word-Dateien im Verzeichnis WordDatei = Dir(WordDateiPfad & "*.doc") With twb Do While WordDatei <> "" 'Datei Öffnen (unsichtbar) AppWd.Visible = False Set DocWd = AppWd.Documents.Open(WordDateiPfad & WordDatei) ' nichts gelesen TextWD = "" 'Erste Zeile der Word-Datei auslesen If InStr(WordDatei, "VoI") > 0 Then DocWd.Range(0, 0).Select TextWD = DocWd.Bookmarks("\Line").Range.Text 'In Excel schreiben .Cells(aktZeile, "C") = "Newsletter VoI" .Cells(aktZeile, "G") = "Verband Organisations- und Informationssysteme" End If If InStr(WordDatei, "EbPP") > 0 Then DocWd.Range(0, 0).Select TextWD = DocWd.Bookmarks("\Line").Range.Text 'In Excel schreiben .Cells(aktZeile, "C") = "Newsletter EbPP" .Cells(aktZeile, "G") = "Electronic Bill Presentment and Payment" End If If InStr(WordDatei, "BvDP") > 0 Then DocWd.Range(0, 0).Select TextWD = DocWd.Bookmarks("\Line").Range.Text 'In Excel schreiben .Cells(aktZeile, "C") = "Newsletter BvDP" .Cells(aktZeile, "G") = "Bundesverband deutscher Postdienstleister e.V." End If If TextWD <> "" Then .Cells(aktZeile, "D") = TextWD .Cells(aktZeile, "J") = WordDatei .Cells(aktZeile, "A") = "Wettbewerberinformationen" .Cells(aktZeile, "B") = "Presseauswertungen" .Cells(aktZeile, "H") = "Abt. 1" aktZeile = aktZeile + 1 End If 'aktuelle Worddatei schließen DocWd.Close savechanges:=False 'nächste Word Datei WordDatei = Dir() Loop End With 'Word schließen und Objekt beenden AppWd.Quit Set DocWd = Nothing End Sub

Hi yogi,
vielen Dank für die Code-Kürzung. Also die Dateien selbst will ich gar nicht auslesen (bzw nur die Word-Dateien, das funktioniert auch schon)
bei den PPTs, XLS und PDFs brauch ich nur ne Methode die im Ordner nach diesen Dateitypen sucht und sie mir auflistet. Am Dateinamen sollte die Kategorie ablesbar sei, sprich die Dateien heissen alle z.B. Studie_NameDerStudie_Datum.ppt oder Vortrag_NameDesVotrages_Datum.pdf
Das Programm sollte dann durchlaufen und alle Dateien auflisten im Excel. Die Word-Dateien so wie oben beschrieben, beim Rest soll der Dateiname = die Beschreibung sein oder muss man dafür auch etwas auslesen in der Datein selbst? Kenn mich da nicht wirklich aus.
Aus der Datei selbst soll nichts ausgelesen werden solange sie kein Word-Dokument ist.
Hoffe ich habs verständlich ausgedrückt, hab paar Mal umgeschrieben *gg*
gruß
Pat

Sub get_datei() Dim datei_name Dim datei_typ As String Dim x As Integer x = 1 datei_name = Dir("D:\Test\*.*") Do Until datei_name = "" datei_typ = UCase(Right(datei_name, 3)) If datei_typ = "PDF" Or datei_typ = "PPT" Then Cells(x, 1) = datei_name x = x + 1 End If datei_name = Dir Loop End Sub

Beliebteste Forumthreads (12 Monate)

Bestehendes Makro um Funktionen erweitern

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread