AW: Mehrere Tabellen vereinen
21.01.2009 15:06:22
fcs
Hallo Dirk,
eine Verlinkung der Masterdatei mit den Detaildateien ist per Fornel nicht ganz einfach und fehleranfällig.
Ich schlage vor die Daten per Makro aus den Datendateien in das Masterblatt zu holen.
Beispieldatei für Master mit Makro.
https://www.herber.de/bbs/user/58662.xls
Gruß
Franz
Sub DatenNachMasterHolen()
Dim wbQuelle As Workbook, wbZiel As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim ZeileZiel As Long, ZeileQuelle As Long
Dim SpaltenZiel() As Long, SpaltenQuelle() As Long, Spalte As Long
Dim intI As Long, intJ As Long
Dim Datenzeilen As Long, ZeileLetzte As Long
Dim TitelSpalten() As String
Dim arrDatei() As String
'Zeile mit den Spaltentiteln in allen Blätter (Ziel- und Quell-Blätetr)
Const ZeileTitel As Long = 1 ' ### ggf. anpassen
'Anzahl der Dateien mit Daten
Const AnzahlDateien As Integer = 2 ' ### ggf. anpassen
'Verzeichnis mit den Datendateien
Const Verzeichnis As String = "C:\Lokale Daten\Test\Daten" ' ### anpassen!
ReDim arrDatei(1 To AnzahlDateien)
'Vollständige Dateinamen dem Array zuweisen
arrDatei(1) = Verzeichnis & Application.PathSeparator & "Testdaten01.xls"
arrDatei(2) = Verzeichnis & Application.PathSeparator & "Testdaten02.xls"
'ggf. Zeilen für weitere Namen ergänzen
Set wbZiel = ThisWorkbook
Set wksZiel = wbZiel.Worksheets("Master") ' Namen ggf. Anpassen
With wksZiel
'Arrays Dimensionieren
Spalte = .Cells(ZeileTitel, .Columns.Count).End(xlToLeft).Column - 2 ' -2 wegen der _
beiden zusätzlichen Spalten für Dateiname und Blattname
ReDim TitelSpalten(1 To Spalte)
ReDim SpaltenZiel(1 To Spalte)
ReDim SpaltenQuelle(1 To Spalte)
'Namen der Spaltentitel einlesen
For Spalte = 1 To UBound(TitelSpalten)
TitelSpalten(Spalte) = .Cells(ZeileTitel, Spalte)
SpaltenZiel(Spalte) = Spalte
Next
'Altdaten im Masterblatt löschen
If .Cells.SpecialCells(xlCellTypeLastCell).Row > ZeileTitel Then
.Range(.Cells(ZeileTitel + 1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
End If
ZeileZiel = ZeileTitel + 1
End With
'Datendateien abarbeiten
For intI = LBound(arrDatei) To UBound(arrDatei)
'datendatei öffnen
Set wbQuelle = Workbooks.Open(Filename:=arrDatei(intI), ReadOnly:=True)
'Tabellenblätter in Quelle abarbeiten
For Each wksQuelle In wbQuelle.Worksheets
With wksQuelle
'letzte Zeile mit Datenbestimmen
ZeileLetzte = 0
For Spalte = 1 To .Cells(ZeileTitel, .Columns.Count).End(xlToLeft).Column
ZeileQuelle = .Cells(.Rows.Count, Spalte).End(xlUp).Row
If ZeileQuelle > ZeileLetzte Then ZeileLetzte = ZeileQuelle
Next
Datenzeilen = ZeileLetzte - ZeileTitel
If Datenzeilen > 0 Then
'Spalten mit den Spaltentiteln in Datendatei ermitteln
For intJ = 1 To UBound(TitelSpalten)
SpaltenQuelle(intJ) = 0
For Spalte = 1 To .Cells(ZeileTitel, .Columns.Count).End(xlToLeft).Column
If TitelSpalten(intJ) = .Cells(ZeileTitel, Spalte).Value Then
SpaltenQuelle(intJ) = Spalte
Exit For
End If
Next
Next
'Daten kopieren
For intJ = 1 To UBound(TitelSpalten)
If SpaltenQuelle(intJ) > 0 Then
.Range(.Cells(ZeileTitel + 1, SpaltenQuelle(intJ)), _
.Cells(ZeileLetzte, SpaltenQuelle(intJ))).Copy _
Destination:=wksZiel.Cells(ZeileZiel, SpaltenZiel(intJ))
Else
MsgBox "Spalte """ & TitelSpalten(intJ) & """ fehlt in Datei " & vbLf _
& wbQuelle.Name & " Blatt " & wksQuelle.Name
End If
Next
With wksZiel
'Dateinamen eintragen
.Range(.Cells(ZeileZiel, UBound(TitelSpalten) + 1), _
.Cells(ZeileZiel + Datenzeilen - 1, UBound(TitelSpalten) + 1)).Value _
= wbQuelle.Name
'BlattNamen eintragen
.Range(.Cells(ZeileZiel, UBound(TitelSpalten) + 2), _
.Cells(ZeileZiel + Datenzeilen - 1, UBound(TitelSpalten) + 2)).Value _
= wksQuelle.Name
'Kopierte Daten in Zieltabelle durch Werte ersetzen -- ggf. weglassen
.Range(.Cells(ZeileZiel, 1), .Cells(ZeileZiel + Datenzeilen - 1, _
UBound(TitelSpalten))).Copy
.Range(.Cells(ZeileZiel, 1), .Cells(ZeileZiel + Datenzeilen - 1, _
UBound(TitelSpalten))).PasteSpecial _
Paste:=xlPasteValues
Application.CutCopyMode = False
End With
'Einfüge-Zeile für Daten aus dem nächstem Blatt
ZeileZiel = ZeileZiel + Datenzeilen
End If
End With
Next
'Datendatei wieder schließen
wbQuelle.Close savechanges:=False
Next
End Sub