Hoffe jemand von euch hat da einen Tipp für mich.
ich würde gerne Tabellen aus Arbeitsmappen in die bereits geöffnete Mappe laden.
Toll wäre es wenn man dieses mit einem "Öffnen" Dialog hinbekommen könnte.
Gruß und an alle ein schönes WE
Axel
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
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
Set Bereich = .Range(.Cells(1, 1), .Cells(Zeile_L, Spalte_L))
End With
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
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