Zusammenfügen mehrerer Dateien

Hallo Zusammen,
ich habe mehrere Dateien die ich gern in eine Datei zusammenfügen würde. Ich habe bereits einen VBA-Code gefunden der mich der Sache ein Stück näher gebracht hat. Leider muss ich dennoch noch zu viel manuell eingreifen, sodass die Zeitersparnis dann auch wieder dahin ist ☺ Daher hoffe ich, dass ihr mir als Profis einmal behilflich sein könnt. Danke an dieser Stelle erstmal für das tolle Forum. Hat mir mehr als einmal sehr gut weitergeholfen!
Die Dateien die ich auslesen möchte liegen alle in einem Ordner, was also schon mal gut ist. ALlerdings benötige ich nicht alle Spalten der auszulesenden Dateien.
Der auszulesende Bereich geht bei "A9" los und endet bei "I9" und alles was darunter folgt. Die Länge der auszulesenden Dateien sind individiuell. Der Anfang hingegen immer gleich. (Die Tabelle geht über Spalte "I" hinaus, diese benötige ich aber nicht!
In meiner neuen Tabelle erstelle ich quasi eimal die Spalten-Überschriften, und möchte, dass nun nahtlos die darunterfolgender Zellen mit den Zellen des Dateien gefüllt werden, ohne dass es Leerzeichen innerhalb der Tabelle gibt.(Diese gibt es in den auszulesenden Dateien nur überhalb von A9:I9
Leider habe ich bislang nur einen Code gehabt, der mir sämtliche Inhalte der Dateien eingefügt hat.
Ich hoffe ihr versteht was ich meine, ansonsten stehe ich natürlich jederzeit für Q&A zur Verfügung, das ist wohl das Mindeste was man machen sollte wenn ihr schon eure Zeit opfert!
Danke für eure Unterstützung
LG
Andy

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Andy,
hier ein Makro aus meinem Bestand angepasst an deine Wünsche bzgl. zu kopierender Zellbereich.
Für die Dateiauswahl wird hier ein Dateiauswahl-Dialog angezeigt mit Mehrfachauswahl.
Gruß
Franz

Option Explicit
Sub Daten_von_extern_laden()
Dim Schleife      As Integer
Dim Bereich       As Range
Dim Zeile_L%, Spalte_L%
Dim arrWkb        As Variant
Dim varWkb        As Variant
Dim wkbQ          As Workbook
Dim wksQ          As Worksheet
Dim nBlatt        As Integer
Dim wksZiel       As Worksheet
Dim Zeile_Ziel    As Long
DateiAuswahl:
'Datei(en) mit zu importierenden Daten auswählen
If wksZiel Is Nothing Then
arrWkb = Application.GetOpenFilename( _
Filefilter:="Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _
Title:="Bitte Datei(en) mit den im neuen Tabellenblatt einzufügenden " & _
& "Daten auswählen", _
MultiSelect:=True)
Else
arrWkb = Application.GetOpenFilename( _
Filefilter:="Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _
Title:="Bitte Datei(en) mit den im Tabellenblatt """ & wksZiel.Name _
& """ einzufügenden Daten auswählen", _
MultiSelect:=True)
End If
If Not IsArray(arrWkb) Then Exit Sub
Application.ScreenUpdating = False
'Neues Tabellenblatt in aktiver Arbeitsmappe einfügen
If wksZiel Is Nothing Then
With ActiveWorkbook
Set wksZiel = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
End With
'erste Einfügezeile in Zieltabelle
Zeile_Ziel = 1
'Spaltentitel eintragen
With wksZiel
.Cells(Zeile_Ziel, 1).Value = "Spalte 1"
.Cells(Zeile_Ziel, 2).Value = "Spalte 2"
.Cells(Zeile_Ziel, 3).Value = "Spalte 3"
.Cells(Zeile_Ziel, 4).Value = "Spalte 4"
.Cells(Zeile_Ziel, 5).Value = "Spalte 5"
.Cells(Zeile_Ziel, 6).Value = "Spalte 6"
.Cells(Zeile_Ziel, 7).Value = "Spalte 7"
.Cells(Zeile_Ziel, 8).Value = "Spalte 8"
.Cells(Zeile_Ziel, 9).Value = "Spalte 9"
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
Zeile_Ziel = 2
End If
Schleife = 0
' Dateien abarbeiten
For Each varWkb In arrWkb
Schleife = Schleife + 1
Set wkbQ = Workbooks.Open(Filename:=varWkb, ReadOnly:=True)
Application.StatusBar = "Datei """ & wkbQ.Name & """ (" & Schleife & " von " _
& UBound(arrWkb) & ") wird importiert"
For nBlatt = 1 To 1  'nur Daten des 1. Tabellenblatts kopieren
Set wksQ = wkbQ.Worksheets(nBlatt)
With wksQ
' Letzte Zelle des Daten-Bereiches ermitteln.
With .UsedRange
Zeile_L = .Row + .Rows.Count - 1
' Letzte Spalte des Daten-Bereiches ermitteln.
Spalte_L = .Column + .Columns.Count - 1
End With
'Bereich festlegen A9:Ixxx
Set Bereich = .Range(.Cells(9, 1), .Cells(Zeile_L, 9))
End With
If Zeile_L >= 9 Then
Bereich.Copy
If Schleife = 1 And Zeile_Ziel = 1 Then
'Bei 1. Datei die Breite der Spalten kopieren
wksZiel.Cells(Zeile_Ziel, 1).PasteSpecial Paste:=xlPasteColumnWidths
End If
'Werte und Zahlenformate kopieren
wksZiel.Cells(Zeile_Ziel, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'Alles kopieren
'        wksZiel.Cells(Zeile_Ziel, 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
'Nächste Einfügezeile berechnnen
Zeile_Ziel = Zeile_Ziel + Bereich.Rows.Count
End If
Next nBlatt
wkbQ.Close savechanges:=False
Set wksQ = Nothing
Set wkbQ = Nothing
Next varWkb
Application.StatusBar = False
Application.ScreenUpdating = True
If MsgBox("Daten wurden importiert. " & vbLf _
& "Daten aus weiteren Dateien in Tabellenblatt """ & wksZiel.Name _
& """ importieren?", _
vbQuestion + vbYesNo, "Daten-Import") = vbYes Then GoTo DateiAuswahl:
End Sub

arrWkb = Application.GetOpenFilename( _ Filefilter:="Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _ Title:="Bitte Datei(en) mit den im neuen Tabellenblatt einzufügenden " & _ "Daten auswählen", _ MultiSelect:=True)

With wksQ ' Letzte Zelle des Daten-Bereiches mit Inhalt ungleich "" ermitteln. Set Bereich = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _ lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious) If Bereich Is Nothing Then Zeile_L = 1 Else Zeile_L = Bereich.Row End If ' Letzte Spalte des Daten-Bereiches mit InHalt ungleich "" ermitteln. Set Bereich = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _ lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious) If Bereich Is Nothing Then Spalte_L = 1 Else Spalte_L = Bereich.Column End If 'Bereich festlegen A9:Ixxx Set Bereich = .Range(.Cells(9, 1), .Cells(Zeile_L, 9)) End With

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread