Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1112to1116
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
Inhaltsverzeichnis

Tabellen zusammenführen, Spaltennamen durchsuchen

Tabellen zusammenführen, Spaltennamen durchsuchen
udo
Hallo, habe vor einiger Zeit hier schonmal Hilfe bekommen. Es ging um ein Makro, welches mehrere Dateien in einer neuen Übersichtstabelle zusammenfasst.
Option Explicit
Const HomeDatei = "LeereArbeitsmappe.xls"              'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Import-Daten"          'Name Tabellenblatt Daten-Import
Const HomeListe = "Datei-Liste"           'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3                       'Erste Zeile Einfügen
Const CopyZeile = 3                       'Erste Zeile Kopieren
Const ListDatei = "A1"                    'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "
Sub SheetsImport()
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Long, NextLine As Long
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, rngFile As Range
Dim lngAnzZ As Long, lngAnzS As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome)
NextLine = HomeZeile
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).ClearContents
'    Application.ScreenUpdating = False  ' NACH dem Test aktivieren
Application.EnableEvents = False
For Each rngFile In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(rngFile) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & rngFile, vbExclamation, "Fehler":  Exit Sub
End If
Set WkbCopy = Workbooks.Open(rngFile, False, True)
Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
lngAnzZ = EndLine - CopyZeile + 1       ' Anzahl zu kopierender Zeilen
lngAnzS = WksCopy.Columns.Count         ' alle Spalten werden kopiert
WksHome.Cells(NextLine, 1).Resize(lngAnzZ, lngAnzS) = _
WksCopy.Cells(CopyZeile, 1).Resize(lngAnzZ, lngAnzS).Value
NextLine = NextLine + lngAnzZ
End If
WkbCopy.Close SaveChanges:=False
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Function GetEndLine(ByRef Wks) As Long
GetEndLine = Wks.Cells(Wks.Rows.Count, 1).End(xlUp).Row
End Function
Ist es möglich, dass nun die Spaltenüberschriften der Quelldateien durchsucht werden und nur bestimmte Spalten in die Übersichtsdatei kommen und somit Reihenfolge oder Anzahl der Spalten der Quelldateien nicht zu Fehlern oder Falschen Daten führen?
Many Thanks.
Auswahl anhand Spaltenüberschriften
04.11.2009 19:22:42
Erich
Hi Udo,
das ist sicher möglich.
Voraussetzung: Du schreibst genau, was du mit "nur bestimmte Spalten" meinst.
Vermutlich sollen die Überschriften der Zieltabelle als Grundlage dienen. Wo stehen die, in welchem Bereich?
Und in welchem Bereich sollen die Überschriften in den Quelldateien gesucht werden?
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
P.S.: Der Code ist aus dem Thread
https://www.herber.de/forum/archiv/1108to1112/t1111330.htm vom 22.10.09.
AW: Tabellen zusammenführen, Spaltennamen durchsuchen
04.11.2009 19:34:11
Daniel
Hi
ja, das würde in etwa nach diesem Schema funktionieren:
dim Ze as long, sp as long
dim Spalten(1 to 3) as String
Spalten(1) = "1. Spaltenüberschrift"
Spalten(2) = "2. Spaltenüberschrift"
Spalten(3) = "3.Spaltenüberschrift"
Set shZiel = ... (hier deine Übersichtstabellenblatt zuweisen)
Set shQuelle = ... (hier deine Quelletabellenblatt zuweisen)
Spalten(1) = "1. Spaltenüberschrift"
Spalten(2) = "2. Spaltenüberschrift"
Spalten(3) = "3.Spaltenüberschrift"
ze = shZiel.Cells(rows.count, 1).end(xlup)+1
For sp = 1 to Ubound(Spalten)
Intersect(shQuelle.rows(1).find(what:=Spalten(sp)).EntireColumn, shQuelle.usedrange.offset( _
1,0)).copy
shZiel.Cells(ze, sp).Pastespecial xlpasteall
next
es wird immer die ganze Spalte mit der gefundenen Überschrift in die Zusammenfassungsdatei kopiert, dabei wird die erste Zeile (überschrift) nicht mitkopiert.
Dadurch, daß sie Spalte per FIND gefunden wird, spielt die Anzahl und Reihenfolge der Spalten in den Quelltabellen keine Rolle, einzige Bedingung ist, daß die Überschriften in allen Dateien gleich sind.
Gruß, Daniel
Anzeige
AW: Tabellen zusammenführen, Spaltennamen durchsuchen
05.11.2009 11:39:01
udo
Hallo vielen Dank euch beiden für die schnellen Antworten. Echt super hier. Die Spaltenüberschriften befinden sich in Zeile 1. Es geht darum, Aufgabenlisten von einigen Personen in einer Gesamtübersicht zu kopieren. Die Spatenüberschriften werden dann gleich sein, das wird abgestimmt. Es kann nur vorkommen, dass sie in verschiedener Reihenfolge in den Quelldateien vorkommen. Oder 1-2 Spaten die in einer Quelldatei vorkommen und in der anderen nicht. Ich werde den Code oben sobald ich Zeit habe ausprobieren und mich spätestens morgen nochmal melden. Danke!
AW: Tabellen zusammenführen, Spaltennamen durchsuchen
05.11.2009 14:05:45
udo
Habs gerade getestet aber will irgendwie nicht funktionieren. Wie muss ich Quellen und Ziel zuweisen?
Und

Sub / End 

Sub muss ich auch noch einfügen oder?
Sorry bin absoluter Anfänger in Sachen VBA.

Anzeige
AW: Tabellen zusammenführen, Spaltennamen durchsuchen
06.11.2009 01:40:26
Daniel
Hi
ja, Sub xxx() und End Sub musst du noch einfügen.

und Quelle und Ziel zuweisen geht in etwa so:
set shZiel = Workbooks("abc.xls").Sheets("Tabelle1")
(die Bezeichnungen in den Anführungszeichen musst du noch anpassen.
je nachdem in welcher Datei sich das entsprechende Tabellenblatt befindet, kann man das auch folgendes verwenden:
set shZiel = activeWorkbook.Sheets("Tabelle1")
set shZiel = ThisWorkbook.Sheets("Tabelle1")
Gruß, Daniel
Tabellen kopieren nach Spaltenüberschriften
05.11.2009 18:02:41
Erich
Hi Udo,
im folgenden Makro werden die Überschriften des Zielblatts in Zeile 1 gelesen.
In jedem Quellblatt werden in Zeile 1 diese Überschriften gesucht, bei Treffer wird die Spalte kopiert.
Viel Spaß beim Testen!

Option Explicit
Const HomeDatei = "LeereArbeitsmappe.xls"    'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Import-Daten"          'Name Tabellenblatt Daten-Import
Const HomeListe = "Datei-Liste"           'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3                       'Erste Zeile Einfügen
Const CopyZeile = 3                       'Erste Zeile Kopieren
Const ListDatei = "A1"                    'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "
Sub SheetsImportS()              ' www.herber.de/forum/archiv/1112to1116/t1114531.htm
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Long, NextLine As Long
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, rngFile As Range
Dim lngAnzZ As Long, lngSpA As Long, ii As Long, aStrU(), varU, lngU As Long
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome)
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).ClearContents
NextLine = HomeZeile
' Titel aus Zeile 1 des Zielblatts in Array aStrU sammeln
With WksHome
lngSpA = .Cells(1, .Columns.Count).End(xlToLeft).Column
If lngSpA > 1 Then
aStrU = Application.Transpose(Application.Transpose( _
.Cells(1, 1).Resize(, lngSpA)))
ElseIf .Cells(1, 1) = "" Then
MsgBox "Abbruch - Keine Spaltenüberschriften in Zeile 1 des Zielblatts"
Exit Sub
Else
ReDim aStrU(1 To 1)
aStrU(1) = .Cells(1, 1).Value2
End If
End With
'    Application.ScreenUpdating = False               ' NACH dem Test aktivieren
Set Fso = CreateObject("Scripting.FileSystemObject")
Application.EnableEvents = False
For Each rngFile In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(rngFile) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & rngFile, vbExclamation, "Fehler":  Exit Sub
End If
Set WkbCopy = Workbooks.Open(rngFile, False, True)       ' Quelle öffnen
Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
lngAnzZ = EndLine - CopyZeile + 1      ' Anzahl zu kopierender Zeilen
For ii = 1 To lngSpA                ' Spaltenüberschriften in Quelle suchen
varU = Application.Match(aStrU(ii), WksCopy.Rows(1), 0)
If IsNumeric(varU) Then
lngU = varU                   ' wenn Treffer, Spalte kopieren
WksHome.Cells(NextLine, ii).Resize(lngAnzZ) = _
WksCopy.Cells(CopyZeile, lngU).Resize(lngAnzZ).Value2
End If
Next ii
NextLine = NextLine + lngAnzZ
End If
WkbCopy.Close SaveChanges:=False
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Function GetEndLine(ByRef Wks) As Long
GetEndLine = Wks.Cells(Wks.Rows.Count, 1).End(xlUp).Row
End Function
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: Tabellen kopieren nach Spaltenüberschriften
06.11.2009 09:31:42
udo
Wow ich bin begeistert. Vielen Dank an euch vorallem an Erich. Klappt hervorragend!

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige