AW: Daten aus mehreren Mappen zusammenführen
20.02.2013 15:46:04
fcs
Hallo Constantin,
nachfolgend ein entsprechendes Makro.
Gruß
Franz
'Erstellt unter Excel 2010
Sub DatenImportieren()
Dim sVerzeichnis As String, sDatei As String
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksSteuerung As Worksheet, wksZiel As Worksheet, wksQuelle As Worksheet
Dim Zeile_S As Long, Zeile_Z As Long, FileCount As Long
Dim Zelle As Range
Const Zeile_1 = 11 '1. Auszulesende Zelle in der Quelltabelle
Const Spalte_L = 30 'letzte auszulesende Spalte in der Quelltabelle
On Error GoTo Fehler
Set wbZiel = ActiveWorkbook
Set wksSteuerung = wbZiel.Worksheets("Tabelle1")
Set wksZiel = wbZiel.Worksheets("Tabelle2")
With wksSteuerung
Application.ScreenUpdating = False
Zeile_Z = 2 '1. Zeile in der im Zielblatt Daten eingefügt werden sollen
'Dateinamen in Tabelle1 abarbeiten
For Zeile_S = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
FileCount = FileCount + 1
Application.StatusBar = "Datei, laufende Nr. " & FileCount & " wird bearbeitet."
With .Cells(Zeile_S, 3)
If Right(.Text, 1) = Application.PathSeparator Then
sVerzeichnis = .Text
Else
sVerzeichnis = .Text & Application.PathSeparator
End If
End With
sDatei = .Cells(Zeile_S, 1)
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open(Filename:=sVerzeichnis & sDatei, ReadOnly:=True, _
Password:=.Cells(Zeile_S, 2).Text)
'Objektvariable die 1. Tabelle zuweisen
Set wksQuelle = wbQuelle.Worksheets(1) '= wbQuelle.Worksheets("Daten")
With wksQuelle
'Letzte Zelle mit Daten in Tabelle 1
Set Zelle = .Cells.Find(What:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If Zelle Is Nothing Then
'keine Daten in Quelltabelle
MsgBox "Keine Daten in Quelltabelle von Datei" & vbLf & wbQuelle.FullName
ElseIf Zelle.Row >= Zeile_1 Then
'Daten in Zieltabelle kopieren
.Range(.Cells(Zeile_1, 1), .Cells(Zelle.Row, Spalte_L)).Copy
wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteFormats
wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'nächste Einfüge-Zeile in Zieltabelle
Zeile_Z = Zeile_Z + Zelle.Row - Zeile_1 + 1
Else
'keine Daten ab inkl. Zeile 11
MsgBox "Keine Daten unterhalb Zeile " & Zeile_1 - 1 & " in Quelltabelle von Datei" _
_
& vbLf & wbQuelle.FullName
End If
End With
wbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wbQuelle = Nothing
Next
End With
wksZiel.Activate
Application.ScreenUpdating = True
MsgBox "Alle Dateien ausgelesen"
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Select
End With
Application.StatusBar = False
Set wbZiel = Nothing: Set wksZiel = Nothing: Set wksSteuerung = Nothing
Set wbQuelle = Nothing
End Sub