AW: Makro Mappen in einer Mappe zusammenfassen
04.07.2013 10:05:57
Klaus
Hallo "Disco",
hab ich bei meiner ersten Antwort vergessen: Wir bevorzugen hier Realnamen / Vornamen! Wenn du wirklich "Discoverer" heisst, entschuldige ich mich.
Um Serverplatz zu sparen, lade ich die Tabelle nicht extra hoch. Hier der Code, auf den du per Button linken darfst:
Option Explicit
Sub HoleVieleExterneDaten()
'holt externe Daten aus allen *.xls* - Dateien eines Ordners
On Error GoTo hell
'mögliche Fehler: keine Dateien im Ordner, Datei-Tab "Day 4 Actuals" existiert nicht, usw usw .. _
Const StartFolder As String = "C:\" 'Um die Pfad-Auswahl immer in C:\ anzufangen ... kannst du _
gerne anpassen!
Const ZielTab As String = "Daten" 'Hier Hin
Const InfoTab As String = "Info" 'so heisst dein Info-Tab
Const ZeileStep As Integer = 3 'immer um 3 Zeilen hochzählen
Const SpalteListe As Long = 4 'im Blatt "Info" ist die Spalte 4 (=D) frei
Const QuelleTabelle As String = "Day 4 Actuals"
Dim ZielZeile As Long
ZielZeile = 7 'in Zeile 7 anfangen
Dim i As Long
Dim r As Range
Dim sPath As String
Dim sFile As String
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Application.ScreenUpdating = False
'Workbook merken
Set wkbOld = ActiveWorkbook
'temporäre Dateinamen-Liste löschen
Sheets(InfoTab).Columns(SpalteListe).ClearContents
'*************** Alle Dateinamen auflisten
i = 1
sPath = ChooseAFolder(StartFolder) 'Holt einen Pfad per Windows-Dialog
'sPath = Sheets(InfoTab).Range("C9").Value 'Alternative: Pfad aus Zelle holen
sFile = Dir(sPath & "*.xls")
Do While sFile ""
Sheets(InfoTab).Cells(i, SpalteListe).Value = sFile
i = i + 1
sFile = Dir()
Loop
'Alle Dateinamen auflisten ***************
'********** Alle Dateien durchlaufen, öffnen, kopieren, schließen
For Each r In Sheets(InfoTab).Cells(1, SpalteListe).Resize(Cells(Sheets(InfoTab).Rows.Count, _
SpalteListe).End(xlUp).Row, 1)
r.Select
Workbooks.Open sPath & r.Value, UpdateLinks:=False
Set wkbNew = ActiveWorkbook
'ich gehe davon aus, es gibt immer nur EINE Tabelle!
With Sheets(QuelleTabelle)
wkbOld.Sheets(ZielTab).Range("B" & ZielZeile).Value = .Range("D7").Value
wkbOld.Sheets(ZielTab).Range("D" & ZielZeile & ":O" & ZielZeile).Value = .Range("F23: _
Q23").Value
wkbOld.Sheets(ZielTab).Range("U" & ZielZeile & ":AF" & ZielZeile).Value = .Range("F32: _
Q32").Value
End With
ZielZeile = ZielZeile + ZeileStep
wkbNew.Close False
Next r
'Alle Dateien durchlaufen, öffnen, kopieren, schließen **********
'temporäre Dateinamen-Liste löschen
Sheets(InfoTab).Columns(SpalteListe).ClearContents
GoTo heaven:
hell:
MsgBox "Fehler in HoleVieleExterneDaten" & vbCrLf _
& "Fehlernummer: " & Err.Number & _
vbCrLf & "Fehlerbeschreibung: " & Err.Description
heaven:
Application.ScreenUpdating = True
End Sub
Public Function ChooseAFolder(sPathStart)
Dim sFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = sPathStart
.Title = "Pick a Folder"
.ButtonName = "choose..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
sFolder = .SelectedItems(1)
If Right(sFolder, 1) "\" Then sFolder = sFolder & "\"
Else
sFolder = ""
End If
End With
If sFolder = "" Then
ChooseAFolder = ""
'MsgBox ("no Folder!")
Else
ChooseAFolder = sFolder
End If
End Function
Die meisten änderbaren Sachen habe ich als CONST nach ganz oben geholt, so dass eine Codeanpassung bei abeweichenden Ordnernamen / Startzeilen usw sehr einfach sein sollte.
Ich habe mit NICHT die Mühe gemacht, deine etwas komplexeren Kopierbereiche mit CONST zu dynamisieren - behalt einfach die Dateistruktur bei :-)
Grüße,
Klaus M.vdT.