Zusammenfügen mehrere XLSM Files zu einer Datei

Hallo zusammen
Ich habe folgendes Problem bei dem ich nicht weiter komme und auch leider per google keine Lösung gefunden habe.
Vorweg. Ich habe immer noch keine Ahnung von VBA.
Ich habe 130 XLMS Dateien, mit jeweils 7 Tabellenblättern.
Alle Files liegen in einem Ordner und sind jeweils unterschiedlich benannt.
Der Aufbau der 130 Files ist absolut identisch.
Die Spaltenanzahl ist pro Tabellenblatt unterschiedlich, aber für alle 130 Tabellen jeweils gleich.
Die Zeilenanzahl ist pro Tabellenblatt unterschiedlich und auch für alle 130 Tabellen unterschiedlich.
Es kann sein dass einzelne Tabellenblätter nur eine Überschrift haben, aber keinen Inhalt.
Es kann sein dass durch merkwürdige Formatierung z.B. nur 20 Zeilen auf einem Tabellenblatt gefüllt sind, aber dennoch 200 Zeilen mit Linien formatiert sind.
Was ich nun möchte.
1. Zusammenfügen aller 130 XLMS Files zu einer Datei
2. Tabellenstruktur (7 Tabellenblätter) soll beibehalten bleiben.
3. Hinzufügen einer Spalte A (A existiert schon, müsste also nach rechts verschoben werden) mit dem Dateinamen der kopierten Datei um die Inhalte später noch den 130 Ursprungstabellen zuordnen zu können.
4. Wenn Ursprungszellen farblich markiert oder der Text farblich unterlegt war, soll das auch im zusammengeführten Dokument der Fall sein. Linien und Rahmen hingegen müssen (können aber) nicht übernommen werden.
Kann mir jemand von Euch helfen?
Viele Grüsse
Matz

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub import_starten() Dim Ordner As String Dim x As Long ReDim strarray(1) zeil = 2 Pfad = GivePath & "\" Ordner = Dir(Pfad, vbDirectory) If Ordner = "" Then MsgBox "kein Ordner oder Dateien!" Exit Sub End If Do While Ordner "" If Ordner "." And Ordner ".." Then If (GetAttr(Pfad & Ordner) And vbDirectory) vbDirectory Then strarray(x) = Ordner x = x + 1 ReDim Preserve strarray(x) End If End If Ordner = Dir Loop For i = 0 To UBound(strarray) - 1 import (Pfad & strarray(i)) Next End Sub Sub import(str As String) Dim wb, wbn As Workbook Dim ZelleLetzte, lz2 As Range Set wb = ThisWorkbook For Each Worksheet In wbn.Worksheets With wbn.Sheets(Worksheet.Name) With .Range("a2:AB2000") Set ZelleLetzte = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _ lookat:=xlWhole, searchdirection:=xlPrevious) End With If ZelleLetzte Is Nothing Then MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " & Worksheet.Name) Else .Range(.Range("a2"), .Range("AB" & ZelleLetzte.Row)).Copy _ Destination:=wb.Sheets(Worksheet.Name).Range("B1") 'hier muss noch was _ passieren 'abfrage bis wo sind die Zellen belegt in zieldatei 'so wir überschrieben 'Spalte a wbn.name & "_" & worksheet.name End If End With Next wbn.Close Set wb = Nothing Set wbn = Nothing End Sub Public Function GivePath() As String Dim fDialog As FileDialog Dim result As Integer 'Dateidialog für Auswahl Set fDialog = Application.FileDialog(msoFileDialogFolderPicker) On Error Resume Next With fDialog .AllowMultiSelect = False .Title = "Ordner wählen" .Filters.Delete .InitialFileName = "c:\" 'Wichtig = "\" result = .Show If (result 0) Then GivePath = Trim(.SelectedItems.Item(1)) Else GivePath = "" End If End With End Function

hab gerade 2 min zeit gehabt und kurz weiter getippt.
ich glaub das funktioniert.
hab hier aberer gerade kein Office 2007 zu Hand.
musst du also testen
nimm dafür am besten einen Ordner in dem nicht so viele Dateien sind.

Sub import_starten()
Dim Ordner As String
Dim x As Long
ReDim strarray(1)
zeil = 2
Pfad = GivePath & "\"
Ordner = Dir(Pfad, vbDirectory)
If Ordner = "" Then
MsgBox "kein Ordner oder Dateien!"
Exit Sub
End If
Do While Ordner  ""
If Ordner  "." And Ordner  ".." Then
If (GetAttr(Pfad & Ordner) And vbDirectory)  vbDirectory Then
strarray(x) = Ordner
x = x + 1
ReDim Preserve strarray(x)
End If
End If
Ordner = Dir
Loop
For i = 0 To UBound(strarray) - 1
import (Pfad & strarray(i))
Next
End Sub
Sub import(str As String)
Dim wb, wbn As Workbook
Dim ZelleLetzte, lz2 As Range
Dim efz As Integer
Set wb = ThisWorkbook
Set wbn = Workbooks.Open(str)
For Each Worksheet In wbn.Worksheets
With wbn.Sheets(Worksheet.Name)
With .Range("a2:AB2000")
Set ZelleLetzte = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlPrevious)
End With
With wb.Sheets(Worksheet.Name).Range("b2:b500")
Set lz2 = .Find(what:="*", after:=.Range("a1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlPrevious)
End With
efz = lz2.Row + 1
If ZelleLetzte Is Nothing Then
MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " &  _
Worksheet.Name)
Else
.Range(.Range("a2"), .Range("AB" & ZelleLetzte.Row)).Copy _
Destination:=ThisWorkbook.Sheets(Worksheet.Name).Range("B" & efz)
ThisWorkbook.Sheets(Worksheet.Name).Range("a" & efz) = str & "_" &  _
Worksheet.Name
End If
End With
Next
wbn.Close
Set wb = Nothing
Set wbn = Nothing
End Sub
Public Function GivePath() As String
Dim fDialog As FileDialog
Dim result As Integer
'Dateidialog für Auswahl
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
On Error Resume Next
With fDialog
.AllowMultiSelect = False
.Title = "Ordner wählen"
.Filters.Delete
.InitialFileName = "c:\" 'Wichtig = "\"
result = .Show
If (result  0) Then
GivePath = Trim(.SelectedItems.Item(1))
Else
GivePath = ""
End If
End With
End Function

Gruß
Dirk

Sub import(str As String) Dim wb, wbn As Workbook Dim ZelleLetzte, lz2 As Range Dim efz As Integer Set wb = ThisWorkbook Set wbn = Workbooks.Open(str) For Each Worksheet In wbn.Worksheets With wbn.Sheets(Worksheet.Name) With .Range("a2:AB2000") Set ZelleLetzte = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _ lookat:=xlWhole, searchdirection:=xlPrevious) End With With wb.Sheets(Worksheet.Name).Range("b2:b500") Set lz2 = .Find(what:="*", after:=.Range("a1"), LookIn:=xlValues, _ lookat:=xlWhole, searchdirection:=xlPrevious) End With efz = lz2.Row + 1 If ZelleLetzte Is Nothing Then MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " & _ Worksheet.Name) Else .Range(.Range("a2"), .Range("AB" & ZelleLetzte.Row)).Copy _ Destination:=ThisWorkbook.Sheets(Worksheet.Name).Range("B" & efz) ThisWorkbook.Sheets(Worksheet.Name).Range("a" & efz) = str & "_" & _ Worksheet.Name End If End With Next wbn.Close Set wb = Nothing Set wbn = Nothing End Sub

ith wb.Sheets(Worksheet.Name).Range("b2:b5000") Set lz2 = .Find(what:="*", after:=.Range("a1"), LookIn:=xlValues, _ lookat:=xlWhole, searchdirection:=xlPrevious) End With --------> efz = lz2.Row + 1 --------------- If ZelleLetzte Is Nothing Then MsgBox ("Keine Daten zum Kopieren vorhanden" & vbCrLf & str & " " & _

Beliebteste Forumthreads (12 Monate)

Zusammenfügen mehrere XLSM Files zu einer Datei

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread