AW: *SCNR*
18.03.2014 17:35:42
Florian
Hi Thorsten!
besten Dank für deine ehrliche Antwort!
Klare Worte sollen mir recht sein!
Ich bin auf der Suche nach einem Code, der mir einen bestimmt definierten Bereich aller Excel-Mappen eines Ordners addiert! Die zu addierenden Mappen sind immer gleich aufgebaut, Bereiche und Tabellennamen sind immer die selben, allerdings kommen von Tag zu Tag immer mehr Dateien hinzu. Dateinamen Plan 001, Plan 002, ... bis ... Plan 999.
Bereich: D1:Z115
Ordnerpfad: I:\Test\Test
Tabellenname: Stückzahlen
Bin hier im Forum auch schon fündig geworden (Code siehe unten), hab allerdings so meine Schwierigkeiten diesen auf meine Ordner- bzw. Datei-Struktur zu editieren!
Die Änderung des Bereichs, des Tabellennamens und Ordnerpfads dürfte ich schon hinbekommen, Allerdings öffnet dieser Code ein Auswahlfenster in welchem ich die zu summierenden Dateien auswählen kann. Ich wollte den Code nun so umschreiben dass er einfach alle Dateien des besagten Ordners ohne Aufforderung addiert - und damit hab ich so meine Schwierigkeiten!
Hier der Code!
'Erstellt unter Excel 2007, Windows Vista
'fcs 2009-10-25
Sub AddierenBreich()
'Wert aus Bereich in mehreren Dateien summieren ohne Öffnen der Dateien
'Variante mit festvorgegebenem Bereich
Call DatenAddieren(BlattName:=ActiveSheet.Name, _
Bereich:=ActiveSheet.Range("C7:K23"))
'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:="C7:K23", _
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(BlattName As String, Bereich As Range)
'Summieren der Zell-Inhalte aus mehreren Dateien, _
dabei ist der Tabellenblatt-Name identisch mit dem aktiven Blatt
'BlattName = Name des Blatts aus dem Werte eingelesen werden sollen
'Bereich = Zellen-Bereich in dem Summen berechnet werden sollen
Dim Zelle As Range
Dim sFormel As String, iPos As Integer
Dim iI As Integer, sDateien As String, arrSummen() As Double
On Error GoTo Fehler
'Array für Summenwerte dimensionieren
With Bereich
ReDim arrSummen(.Row To .Row + .Rows.Count - 1, .Column _
To .Column + .Columns.Count - 1)
End With
'Datei-Auswahl-Dialog anzeigen
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte zu addierende Dateien auswählen " _
& "- Mehrfachauswahl ist möglich"
.AllowMultiSelect = True
.ButtonName = "Auswählen"
.InitialView = msoFileDialogViewList
.InitialFileName = VBA.CurDir & "\*.xl*" 'Pfad ggf. anpassen
If .Show = -1 Then
Bereich.ClearContents
'Gewählte Dateien abarbeiten
For iI = 1 To .SelectedItems.Count
'einzutragende Arrayformel für Bereich ermitteln und einfügen
'Position des letzten Pfadtrennzeichens ermitteln
iPos = InStrRev(.SelectedItems(iI), Application.PathSeparator)
'"='C:\Users\Public\Test\01\[Data03.xls]Daten'!R7C3:R23C11"
sFormel = "='" & Left(.SelectedItems(iI), iPos) _
& "[" & Mid(.SelectedItems(iI), iPos + 1) & "]" _
& BlattName & "'!" & Bereich.Address(ReferenceStyle:=xlR1C1)
Bereich.FormulaArray = sFormel
Bereich.Calculate
'Formelergebnisse im Array addieren
For Each Zelle In Bereich
arrSummen(Zelle.Row, Zelle.Column) = _
arrSummen(Zelle.Row, Zelle.Column) + Zelle.Value
Next
'Ausgewählte Dateien in Variable zusammenfassen
sDateien = sDateien & vbLf & Mid(.SelectedItems(iI), iPos + 1)
Next
'Summierte Werte aus Array in Bereich eintragen
'Formellöschen
Bereich.ClearContents
'Werte aus Array mit Summen eintragen
Bereich.Value = arrSummen
MsgBox "Werte aus folgenden Dateien wurden addiert:" & vbLf & sDateien, _
vbOKOnly, "Daten aus mehreren Dateien addieren"
End If
End With
Fehler:
With Err
If .Number 0 Then
Select Case .Number
Case 13 'Typen unverträglich
MsgBox "Fehler-Nr.:" & .Number & vbLf & .Description & vbLf & vbLf _
& "In einer der selektierten Dateien steht im Bereich Text!"
Bereich.ClearContents
Case Else
MsgBox "Fehler-Nr.:" & .Number & vbLf & .Description
End Select
End If
End With
Set Zelle = Nothing
ReDim arrSummen(0, 0)
End Sub
Hab auch noch die Mappe hochgeladen in welcher die Summierung erfolgen soll (Code bereits integriert jedoch noch nicht editiert):
https://www.herber.de/bbs/user/89729.xlsm
Ich hab nun wirklich so einiges ausprobiert und in Foren gelesen, bin in VBA allerdings alles andere als sattelfest um es für meine Vorstellungen hinzubekommen.
Vielleicht ist das für dich ja ein Klacks und du kannst mir den Code im Hand umdrehen umschreiben.
Sollte es doch aufwendiger sein werde ich einen neuen Beitrag verfassen und versuchen den damaligen Verfasser des Codes darauf aufmerksam zu machen!
Ich hoffe meine Worte und Beschreibungen waren klar genug! ;-)
Besten Dank im Voraus!
Florian