AW: Sverweis mehrere Dateien?
12.10.2009 13:04:59
MaxKuba
Hab einen super code zum zusammenfuehren von Exceldateien gefunden:
Option Explicit
Sub Dateien_Zusammenfuehren()
'Als erstes Ordner im Explorer selectieren!!
' Führt die Tabellen aus den Dateien in Verzeichnis in einer Datei zusammen
' Dabei werden die Daten aus den Tabellen der Quell-Dateien in eine oder mehr Ziel-Tabelle(n) _
_
_
kopiert
' Dabei werden in den Tabellen alle Formeln in Werte verwandelt
Dim Verzeichnis As String
Dim wbQuelle As Workbook, wksQuelle As Worksheet, wbZiel As Workbook, wksZiel As Worksheet
Dim Datei As String, ZeileDaten As Long, Zeile As Long, wksListe As Worksheet
Dim Spaltenformat As Boolean, i As Integer, Blatt As Integer
'Neue Datei zum Zusammenführen der Tabellen Dateien anlegen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksZiel = wbZiel.Sheets(1)
Blatt = 1 'Zählnummer für Blätter mit Daten
wksZiel.Name = "Tabelle" & Blatt
wbZiel.Worksheets.Add After:=Sheets(1) 'Blatt das die zusammengefassten Tabellen _
protokolliert
Set wksListe = ActiveSheet
wksListe.Name = "Importprotokoll"
Zeile = 1
wksListe.Cells(Zeile, 1) = "Import-Protokoll"
Zeile = 2
wksListe.Cells(Zeile, 1) = "Quell-Datei"
wksListe.Cells(Zeile, 2) = "Quell-Tabelle"
wksListe.Cells(Zeile, 3) = "eingefügt in Blatt"
ZeileDaten = 1
Application.ScreenUpdating = False
'Exceldateien im Verzeichnis Öffnen
Datei = Dir(Verzeichnis & "*.xls")
Spaltenformat = False
Do Until Datei = ""
Application.StatusBar = "Die " & Zeile - 1 & ". Datei wird bearbeitet, Dateiname: " & _
Datei
Set wbQuelle = Workbooks.Open(Filename:=Verzeichnis & Datei, ReadOnly:=True)
For Each wksQuelle In wbQuelle.Worksheets 'Variante für alle Tabellenblätter
With wksQuelle
If ZeileDaten + .UsedRange.Rows.Count > wksZiel.Rows.Count Then
Blatt = Blatt + 1
wbZiel.Worksheets.Add After:=Sheets(Blatt - 2) 'weiteres Blatt für Daten
Set wksZiel = wbZiel.Sheets(Blatt)
wksZiel.Name = "Tabelle" & Blatt
Spaltenformat = False
ZeileDaten = 1
End If
If Spaltenformat = False Then
'Aus der 1. Tabelle der nächsten, Datei werden die Spaltenbreiten ausgelesen und in _
die Ziel-Tabelle übertragen
For i = 1 To .UsedRange.Column + .UsedRange.Columns.Count - 1
wksZiel.Columns(i).ColumnWidth = .Columns(i).ColumnWidth
Next i
Spaltenformat = True
End If
Zeile = Zeile + 1
wksListe.Cells(Zeile, 1) = wbQuelle.FullName
wksListe.Cells(Zeile, 2) = wksQuelle.Name
wksListe.Cells(Zeile, 3) = Blatt
'Formeln durch Werte ersetzen
.UsedRange.Copy
.Range(.UsedRange.Address).PasteSpecial Paste:=xlPasteValues
.UsedRange.EntireRow.Copy Destination:=wksZiel.Cells(ZeileDaten, 1)
ZeileDaten = ZeileDaten + .UsedRange.Rows.Count
End With
Next wksQuelle
wbQuelle.Close Savechanges:=False
Datei = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
wbZiel.Activate
'Protokollliste Formatieren
wksListe.Select
wksListe.Columns("A:B").AutoFit
wksListe.Range("A3").Select
ActiveWindow.FreezePanes = True
' Datei-Speichern Dialog anzeigen
Application.Dialogs(xlDialogSaveWorkbook).Show
End Sub