AW: funktioniert bei mir ohne Probleme ...
17.11.2014 08:37:24
Florian
Hallo Christian,
die Dateien im besagten Ordner lauten:
Plan 001.xlsm
Plan 002.xlsm
Plan 003.xlsm
.
.
.
Plan 999.xlsm (max.)
Hier nochmals der gesamte Code.
'Erstellt unter Excel 2007, Windows Vista
'fcs 2009-10-25
Sub Addieren_Listenmattenstückzahlen()
'In das Blatt Blockzuteilung wechseln
Sheets("Blockzuteilung").Select
'Wert aus Bereich in mehreren Dateien summieren ohne Öffnen der Dateien
'Variante mit festvorgegebenem Bereich
Call DatenAddieren_Listenmattenstückzahlen(BlattName:=ActiveSheet.Name, _
Bereich:=ActiveSheet.Range("T9:Y88"))
'Variante mit Bereichsauswahl
'Call DatenAddieren(BlattName:=ActiveSheet.Name, _
Bereich:=Application.InputBox( _
Prompt:="Bitte den zu summierenden Bereich selektieren", _
Title:="Daten aus mehreren Dateien addieren", _
Default:="T9:Y88", _
Type:=8))
Fehler:
With Err
If .Number 0 Then
Select Case .Number
Case 424 'Bereichsauswahl wurde abgebrochen
'do nothing
Case Else
MsgBox "Fehler-Nr.:" & .Number & vbLf & .Description
End Select
End If
End With
End Sub
Sub DatenAddieren_Listenmattenstückzahlen(BlattName As String, Bereich As Range)
Dim rngDest As Range
Dim sFormel As String, iPos As Integer
Dim lstrPath As String, lstrFile As String
lstrPath = Range("D1") ' Pfad anpassen!!!
lstrFile = Dir(lstrPath & "Plan*.xlsm")
If lstrFile = "" Then
MsgBox "Im Verzeichnis keine Plan*-Dateien vorhanden"
Exit Sub
End If
Set rngDest = Bereich
Do Until lstrFile = ""
iPos = InStrRev(lstrPath & lstrFile, Application.PathSeparator)
sFormel = "='" & Left(lstrPath & lstrFile, iPos) _
& "[" & Mid(lstrPath & lstrFile, iPos + 1) & "]" _
& BlattName & "'!" & Bereich.Address(ReferenceStyle:=xlR1C1)
' Forrmel eintragen
rngDest.FormulaArray = sFormel
' in Werte wandeln
rngDest.Value = rngDest.Value
' Zielbereich versetzen
Set rngDest = rngDest.Offset(Bereich.Rows.Count)
lstrFile = Dir
Loop
Set rngDest = Nothing
End Sub
Besten Dank im Voraus und schöne Grüße!
Florian
