Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1100to1104
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Daten aus zwei Tabellen zusammenführen
René
Hallo liebe Excelprofis,
ich habe ein Makro mit dem ich zwei Tabellen zusammenführen kann. Allerdings gibt es noch ein _ kleines Problem. Beide Tabellen stehen in einer Datei in der noch andere Tabellen sind. Daher ist es erforderlich das man dem Makro sagt führe nur die Daten aus der Tabelle "Daten" und aus der Tabelle "Daten Kurzcheck" zusammen. Es soll auch aus beiden Tabellen nicht die erste Zeile mit kopiert werden weil das die Kopfzeile ist. Könnt ihr mir bitte helfen?

Private Sub CommandButton5_Click()
Dim a, b, c As Long
For a = 2 To Sheets.Count
For b = 1 To Sheets(a).Cells(Rows.Count, 1).End(xlUp).Row
c = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets(a).Rows(b).Copy
Sheets(1).Rows(c).Insert
Next b
Next a
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Daten aus zwei Tabellen zusammenführen
06.09.2009 23:08:51
Oberschlumpf
Hi René
Handelt es sich bei dieser neuen Frage um das gleiche Problem, wie in diesem Thread:
https://www.herber.de/forum/messages/1100848.html
Wenn ja, warum bleibst du nicht im alten Thread.
Wenn nein, wann antwortest du denn im alten Thread?
Ciao
Thorsten
AW: Daten aus zwei Tabellen zusammenführen
06.09.2009 23:11:22
D.Saster
Hallo,
ist doch ganz easy.
Schleife For a= ... weg!
For b = 2 to Sheets("Daten Kurzcheck").cells(....
Sheets("Daten Kurzcheck").Rows(b).copy
...
Sheets("Daten").Rows(c).Insert
Gruß
Dierk
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

Anzeige

331 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige