Daten aus mehreren Excel-Dateien importieren mit V

Private Sub cmdImport_Click() Application.ScreenUpdating = False Dim Quelle As Object, Ziel As Object Dim Datei As String On Error GoTo Fehler 'Dialog "Datei öffnen" anzeigen Datei = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _ "*.xls; *.xlsx; *.xlsm") 'Abbrechen falls keine Datei ausgewählt If Datei = "Falsch" Then MsgBox "keine Datei ausgewählt", , "Abbruch" Exit Sub End If 'MsgBox "Ausgewählte Datei: " & Datei, , "" 'Ausgewählte Datei öffnen Workbooks.Open Filename:=Datei Set Quelle = ActiveWorkbook.Worksheets(1) Set Ziel = ThisWorkbook.Worksheets(1) 'kopieren und einfügen Quelle.UsedRange.Copy Ziel.Cells(2, 1) ActiveWorkbook.Close 'Speicher freigeben Set Quelle = Nothing Set Ziel = Nothing Exit Sub Fehler: Set Quelle = Nothing Set Ziel = Nothing MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _ & "Beschreibung: " & Err.Description _ , vbCritical, "Fehler" Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub cmdImport_Click() Application.ScreenUpdating = False Dim wbQuelle As Workbook, Quelle As Worksheet, Ziel As Worksheet Dim Datei As Variant, varDateien Dim Zeile_Z As Long, Zeile_Q1 As Long, Zeile_Q2 As Long Dim rngZelle As Range On Error GoTo Fehler 'Dialog "Datei öffnen" anzeigen varDateien = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _ "*.xls; *.xlsx; *.xlsm", _ Title:="Bitte zu importieren Datei(en) auswählen", MultiSelect:=True) 'Abbrechen falls keine Datei ausgewählt If Not IsArray(varDateien) Then MsgBox "keine Datei ausgewählt", , "Abbruch" Exit Sub End If Application.ScreenUpdating = False Set Ziel = ThisWorkbook.Worksheets("Sachbearbeiter") With Ziel 'Startzeile setzen Set rngZelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _ lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious) If rngZelle Is Nothing Then Zeile_Z = 16 Else Zeile_Z = rngZelle.Row End If If Zeile_Z = Zeile_Q1 Then 'kopieren und einfügen ' .Range(.Rows(Zeile_Q1), .Rows(Zeile_Q2)).Copy Ziel.Cells(Zeile_Z, 1) .Range(.Cells(Zeile_Q1, 1), .Cells(Zeile_Q2, 17)).Copy Ziel.Cells(Zeile_Z, 1) 'nächste Einfügezeile Zeile_Z = Zeile_Z + Zeile_Q2 - Zeile_Q1 + 1 End If End With NextDatei: wbQuelle.Close savechanges:=False 'Speicher freigeben Set Quelle = Nothing Set wbQuelle = Nothing Next Datei Application.ScreenUpdating = True Fehler: With Err Select Case .Number Case 0 'alles OK Case Else If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False MsgBox "FehlerNr.: " & .Number & vbNewLine & vbNewLine _ & "Beschreibung: " & .Description, _ vbCritical, "Fehler" End Select End With 'Speicher freigeben Set Quelle = Nothing Set wbQuelle = Nothing Set Ziel = Nothing Application.ScreenUpdating = True End Sub

Hallo Franz = Excelheld,
danke, danke, danke!!!!
Der Code klappt super. Ich bin besser im Code lesen, als im Code erstellen.
Ich habe jetzt noch 2 Probleme:
1.
Ist es möglich, dass er nur Werte einfügt? Ohne Formeln und Formate?
2.
In der anderen Datei befinden sich Formeln, denen ich einen Namen gegeben habe. Das sind Listen, die ich in meinen Dropdownlisten anzeige. Diese Listen mit den selben Namen sind sowohl in der Zieldatei, als auch in den Importdateien vorhanden. Leider fragt er mich jetzt bei jeder Datei, die er einfügen will mehrmals:
Die Formel die eingefügt werden soll, enthält einen Namen, der bereits in der Zieltabelle vorhanden ist. Soll die vorhandene Definition verwendet werden?
Ich müsste das dann ca. 50 x mit Ja bestätigen. Je nachdem wie viele Dateien im Ordner vorhanden sind.
Kann man das irgendwie abschalten?
Ich habe Dateien, wo ich auch Tabellenblätter exportiere. Da verwende ich immer einen Code der die Namen löscht und den Link, damit keine Verknüpfungen vorhanden sind. Kann man das irgendwie da rein basteln, damit die Namen nicht mit "kopiert" werden?
Dim i As Integer
Dim myLinks As Variant
Dim A As Integer, MyName As Name
With ActiveWorkbook
myLinks = .LinkSources(xlExcelLinks)
If Not IsEmpty(myLinks) Then
For i = 1 To UBound(myLinks)
.BreakLink myLinks(i), xlExcelLinks
Next i
End If
With ActiveWorkbook
For Each MyName In .Names
MyName.Delete
Next
End With
Liebe Grüße
Anja

Hallo Anja,
die Anpassung in folgendem Abschnitt scheint auszureichen, damit beide Probleme gelöst sind.

      If Zeile_Q2 >= Zeile_Q1 Then
'kopieren und einfügen (nur Formeln und Formate)
'      .Range(.Rows(Zeile_Q1), .Rows(Zeile_Q2)).Copy
.Range(.Cells(Zeile_Q1, 1), .Cells(Zeile_Q2, 17)).Copy
Application.DisplayAlerts = False
Ziel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteFormats
Ziel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = True
Application.CutCopyMode = False 'Zwischenablage leerräumen
'nächste Einfügezeile
Zeile_Z = Zeile_Z + Zeile_Q2 - Zeile_Q1 + 1
End If

Wenn du in der Quelle vor dem Kopieren bezüglich Namen, und Formel-Verknüpfungen gründlich aufräumen willst, dann sieht es wie folgt aus.
Gruß
Franz

Private Sub cmdImport_Click()
Dim wbQuelle As Workbook, Quelle As Worksheet, Ziel As Worksheet
Dim Datei As Variant, varDateien
Dim Zeile_Z As Long, Zeile_Q1 As Long, Zeile_Q2 As Long
Dim rngZelle As Range
Dim objName As Name, varLinks As Variant, i As Integer
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
varDateien = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", _
Title:="Bitte zu importieren Datei(en) auswählen", MultiSelect:=True)
'Abbrechen falls keine Datei ausgewählt
If Not IsArray(varDateien) Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
Application.ScreenUpdating = False
Set Ziel = ThisWorkbook.Worksheets("Sachbearbeiter")
With Ziel
'Startzeile setzen
Set rngZelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
Zeile_Z = 16
Else
Zeile_Z = rngZelle.Row
End If
If Zeile_Z = Zeile_Q1 Then
'Formeln im Quell-Tabellenblatt durch Werte ersetzen
With .UsedRange
.Value = .Value
End With
'Namen in Quelle löschen
For Each objName In wbQuelle.Names
If objName.Visible = True Then
objName.Delete
End If
Next
'Links in Quelle löschen
varLinks = wbQuelle.LinkSources(xlExcelLinks)
If Not IsEmpty(varLinks) Then
For i = 1 To UBound(varLinks)
wbQuelle.BreakLink varLinks(i), xlExcelLinks
Next i
End If
'kopieren und einfügen
Application.DisplayAlerts = False
'      .Range(.Rows(Zeile_Q1), .Rows(Zeile_Q2)).Copy Ziel.Cells(Zeile_Z, 1)
.Range(.Cells(Zeile_Q1, 1), .Cells(Zeile_Q2, 17)).Copy Ziel.Cells(Zeile_Z, 1)
Application.CutCopyMode = False 'Zwischenablage leerräumen
Application.DisplayAlerts = True
'nächste Einfügezeile
Zeile_Z = Zeile_Z + Zeile_Q2 - Zeile_Q1 + 1
End If
End With
NextDatei:
wbQuelle.Close savechanges:=False
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Next Datei
Application.ScreenUpdating = True
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
MsgBox "FehlerNr.: " & .Number & vbNewLine & vbNewLine _
& "Beschreibung: " & .Description, _
vbCritical, "Fehler"
End Select
End With
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Set Ziel = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

Daten aus mehreren Excel-Dateien importieren mit V

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

317 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten aus mehreren Excel-Dateien importieren mit V

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

317 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread