Variante - Daten aus geschlossenen Mappen addieren
25.10.2009 09:51:21
fcs
Hallo Wolfgang,
hier noch eine Variante.
Die zu addierenden Dateien werden in einem Dateidialogfenster mit Multiselektion ausgewählt.
Die Berechnungsformeln werden temporär in die Zellen des Bereichsgeschrieben und die Ergebnisse in einem Array summiert und zum Schluss in den Bereich geschrieben.
Gruß
Franz
'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