AW: Daten aus zwei Tabellen zusammenführen
07.09.2009 13:05:14
fcs
Halo Rene,
hier dann die Luxus-Version mit Auswahl-möglichkeit der beiden Dateien.
Als Ziel wird hier eine neue Arbeitsmappe angelegt.
Gruß
Franz
'Prozeduren erstellt mit Excel 2003
Sub Tabellenblaetter_zusammenfassen()
'Zwei Tabellen mit identischem Spaltenaufbau zusammenfassen
Dim strVerzeichnis As String, strVerUnter As String
Dim strDatei1 As String, strDatei2 As String, strDatei As String
Dim wksQuelle As Worksheet, wbQuelle As Workbook, bolOpen As Boolean
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim lngZeile As Long
Const AnzTitelzeilen = 1 'Anzahl der Titelzeilen in den Tabellen 'ggf. ANPASSEN!
'verzeichnis mit den Dateien
strVerzeichnis = "C:\Lokale Daten\Test\Zwischenordner" ' ANPASSEN!
'Unterverzeichnis für zusammengefasste Datei
strVerUnter = "checklisten" 'ANPASSEN!
'Namen der zusammenzuführenden Dateien auswählen
strDatei1 = selectFile(strDir:=strVerzeichnis, strInitialName:="Rene_Data", _
strTitel:="Bitte 1. Datei auswählen") 'ANPASSEN!
If strDatei1 = "" Then GoTo Ende
strDatei2 = selectFile(strDir:=strVerzeichnis, strInitialName:="Rene_Data", _
strTitel:="Bitte 2. Datei auswählen") 'ANPASSEN!
If strDatei2 = "" Then GoTo Ende
'1. datei öffnen
bolOpen = False
If CheckWorkbookOpen(SeparateFilename(strDatei1)) = False Then
Set wbQuelle = Workbooks.Open(Filename:=strDatei1, ReadOnly:=True)
Else
Set wbQuelle = Workbooks(SeparateFilename(strDatei1))
bolOpen = True
End If
Set wksQuelle = wbQuelle.Worksheets(1) 'ANPASSEN! 1 ggf.durch Namen ersetzen
'1. tabelle in neue Mappe kopieren
'Die nachfolgenden 3 Zeilen anpassen, wenn du in eine existierende Datei '
kopieren willst
wksQuelle.Copy
Set wbZiel = ActiveWorkbook
Set wksZiel = wbZiel.Worksheets(1)
'1. Datei wieder schließen
If bolOpen = False Then wbQuelle.Close savechanges:=False
With wksZiel
'nächste freie Zeile in Zieltabelle
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
'2. Datei öffnen
bolOpen = False
If CheckWorkbookOpen(SeparateFilename(strDatei2)) = False Then
Set wbQuelle = Workbooks.Open(Filename:=strDatei2, ReadOnly:=True)
Else
Set wbQuelle = Workbooks(SeparateFilename(strDatei2))
bolOpen = True
End If
Set wksQuelle = wbQuelle.Worksheets(1) 'ANPASSEN! 1 ggf. durch Namen ersetzen
With wksQuelle
'Daten aus Datei 2 ab unterhalb Titelzeile kopieren
.Range(.Rows(AnzTitelzeilen + 1), _
.Rows(.Cells(.Rows.Count, 1).End(xlUp).Row)).Copy _
Destination:=wksZiel.Cells(lngZeile, 1)
End With
'2. Datei wieder schhließen
If bolOpen = False Then wbQuelle.Close savechanges:=False
' Direkt mit vorgegebenem Namen + Datum_Uhrzeit speichern
' wbZiel.SaveAs Filename:=strVerzeichnis & Application.PathSeparator _
& strVerUnter & Application.PathSeparator _
& "MyFileName_" & Format(Now, "YYYYMMDD_hhmmss"), _
FileFormat:=xlWorkbookNormal, addtomru:=True 'ANPASSEN!
' Datei via Dialog mit vorgeschlagenem Namen + Datum_Uhrzeit speichern
Application.Dialogs(xlDialogSaveAs).Show Arg1:=strVerzeichnis & Application.PathSeparator _
& strVerUnter & Application.PathSeparator _
& "MyFileName_" & Format(Now, "YYYYMMDD_hhmmss") 'ANPASSEN!
Ende:
Set wksQuelle = Nothing: Set wbQuelle = Nothing
Set wbZiel = Nothing: Set wksZiel = Nothing
End Sub
Function selectFile(Optional strDir As String, Optional strInitialName As String, _
Optional strFilter As String = "*.xls;*.xlsx;*.xlsm", _
Optional strTitel As String = "Bitte zu öffnende Datei wählen") As String
'Funktion gibt den im Dialog ausgewählten Dateinamen oder Leerstring zurück
'strDir = Optionales Verzeichnis, in dem Datei ausgewählt werden soll
'strInitialName = Optionaler Anfang für anzuzeigende Dateinamen
'strFilter = Filter für anzuzeigende Datei-Typen, Standard: "*.xls;*.xlsx;*.xlsm"
Dim strCurDir, lngIndex As Long
strCurDir = VBA.CurDir
If strDir "" Then
VBA.ChDir strDir
End If
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = strInitialName
.Title = strTitel
With .Filters
lngIndex = .Count + 1
.Add "Files", strFilter, lngIndex
End With
.FilterIndex = lngIndex
.InitialView = msoFileDialogViewDetails
If .Show False Then
selectFile = .SelectedItems(1)
Else
selectFile = ""
End If
End With
VBA.ChDir strCurDir
End Function
Function SeparateFilename(strName As String) As String
'Trennt das Verzeichnis vom Dateinamen
If InStr(1, strName, Application.PathSeparator) = 0 Then
SeparateFilename = strName
Else
SeparateFilename = Mid(strName, InStrRev(strName, Application.PathSeparator))
End If
End Function
Function CheckWorkbookOpen(strWorkbookName As String) As Boolean
'Prüft, ob Arbeitsmappe schon geöffnet
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = strWorkbookName Then
CheckWorkbookOpen = True
Exit For
End If
Next
End Function