Word-Dateien zusammenfügen (Excel-Liste

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub docs_zusammenführen() 'leeres Dokument sollte das aktive Dokument sein!! Documents.Add ChDir "C:\DeinVerzeichnis" 'hier liegen die Einzeldokumente die in der Schleife angearbeitet werden FName = Dir("*.DOCX") While FName "" With Selection .InsertFile FileName:=FName, ConfirmConversions:=False .InsertParagraphAfter .InsertBreak Type:=wdSectionBreakNextPage .Collapse Direction:=wdCollapseEnd End With FName = Dir() Wend End Sub

Sub docs_zusammenführen() Dim wdApp As Object Dim wdDoc As Object Dim fPath As String Dim sourcePath As String Dim fName As String Dim zeile As Long zeile = 5 fPath = "C:\Zielordner\DocSammler" 'Anpassen fName = "MainDoc.docx" 'Anpassen sourcePath = "C:\Quellordner" 'Anpassen, der Ordner der Docs 'Word-Applikation starten Set wdApp = CreateObject("Word.Application") 'das Zieldokument öffnen Set wdDoc = wdApp.Documents.Open(fPath & "\" & fName) With wdApp .Visible = True .Activate End With With wdApp.Selection .endkey Unit:=6 'wdStory .TypeParagraph .InsertBreak Type:=2 'wdSectionBreakNextPage End With While Sheets("Liste").Cells(zeile, 2) "" And _ Sheets("Liste").Cells(zeile, 4) "" With wdApp.Selection .endkey Unit:=6 'wsStory .InsertFile Filename:=sourcePath & "\" & _ Sheets("Liste").Cells(zeile, 2), _ ConfirmConversions:=False .InsertParagraphAfter .InsertBreak Type:=2 'wdSectionBreakNextPage .Collapse Direction:=0 'wdCollapseEnd End With zeile = zeile + 1 Wend 'wdDoc Close:=savechanges = True ' wenn das Doc geschlossen weren soll 'wdApp.qouit ' wenn Word beendet werden soll Set wdDoc = Nothing Set wdApp = Nothing End Sub

Hallo Jochen,
super, funktioniert. ganz ganz herzlichen Dank.
Noch eine kleine Frage.
mit folgendem Code (Ausschnitt) lese ich alle Dateinamen aus dem Verzeichnis in die Spalte C ein.
Er schreibt mir da nur den Dateinamen ohne Erweiterung.
Was müsste ich ändern das auch die Dateierweiterung mit notiert wird?
For lngColumn = 2 To 5
.NewSearch = True
.SearchLike = Switch(lngColumn = 2, wks.Range("J1"), lngColumn = 5, wks.Range("M1")) & "*"
lngFileCount = .Execute(Sort_by_Name, Sort_Order_Ascending)
For ialngIndex = 1 To lngFileCount
Call wks.Hyperlinks.Add(Anchor:=wks.Cells(ialngIndex + 5, lngColumn + 1), _
Address:=.Files(ialngIndex).Path, TextToDisplay:=Left$(.Files(ialngIndex).Filename, _
InStrRev(.Files(ialngIndex).Filename, ".") - 1))
wks.Cells(ialngIndex + 5, 1) = ialngIndex ' Nummerierung
wks.Cells(ialngIndex + 5, lngColumn + 3) = .Files(ialngIndex).LastModify ' Speicherdatum
Danke noch einmal für deine Hilfe
Viele Grüße Ulli

Hallo Jochen,
hier der komplette Code, mit dem werden die ausgewählten Dateien in Spalte B geschrieben:
Option Explicit


Sub sbTest()
Dim lloRow As Long, lloNext As Long, liMax As Integer, larstrCity() As String, liIdx As Integer
ReDim larstrCity(1, 0)
With Sheets("Liste") 'ändern, wenn Original nicht Tabelle1 heißt
liMax = Application.WorksheetFunction.Max(.Range("D5:D" & .Cells(.Rows.Count, 4).End(xlUp).Row))
For lloNext = 1 To liMax
For lloRow = 5 To .Cells(.Rows.Count, 4).End(xlUp).Row
If .Range("D" & lloRow).Value = lloNext Then
larstrCity(0, UBound(larstrCity, 2)) = .Range("D" & lloRow).Value
larstrCity(1, UBound(larstrCity, 2)) = .Range("C" & lloRow).Value
ReDim Preserve larstrCity(1, UBound(larstrCity, 2) + 1)
End If
Next
Next
ReDim Preserve larstrCity(1, UBound(larstrCity, 2) - 1)
Sheets.Add after:=Sheets(Sheets.Count)
lloRow = 1
For liIdx = 0 To UBound(larstrCity, 2)
Range("A" & lloRow).Value = larstrCity(0, liIdx)
Range("B" & lloRow).Value = larstrCity(1, liIdx)
lloRow = lloRow + 1
Next
With ActiveSheet.Sort.SortFields
.Clear
.Add2 Key:=Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add2 Key:=Range("B1:B" & Cells(Rows.Count, 1).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With ActiveSheet.Sort
.SetRange Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lloNext = 5
For lloRow = 1 To Cells(Rows.Count, 2).End(xlUp).Row
.Range("B" & lloNext).Value = Range("B" & lloRow).Value
lloNext = lloNext + 1
Next
With Application
.DisplayAlerts = False
ActiveSheet.Delete
.DisplayAlerts = True
End With
End With
Worksheets("Liste").Activate
'Call PräsentationenZusammenfügen
End Sub

Beliebteste Forumthreads (12 Monate)

Word-Dateien zusammenfügen (Excel-Liste

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

24 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Word-Dateien zusammenfügen (Excel-Liste

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

24 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread