title image


Smiley Re: Werte aus verschiedenen Arbeitsblättern in einem Blatt addieren
Hallo!



Eigentlich wäre KOnsolidieren schon das rechte Mittel!



Ansonsten kannst Du ja mal den folgenden Code ausprobieren. Bitte vorher Sicherheitskopien anlegen! Ich habe den Code lange nicht mehr angewendet und bin mir deshalb nicht sicher, ob alles fehlerfrei abläuft.



Option Explicit



'-----------------------------------------------------------------------------------

'VBA-Prozedur: Gesamtstatistik_Erstellen

'Erstellt am: 11.11.2003

'von: manes (Spotlight-User)

'

'Kurzbeschreibung:

'Die Prozedur dient zum Sammeln von numerischen Daten aus mehreren xls-Dateien.

'Voraussetzungen:

'Alle Quelldateien und die Zieldatei müssen im selben Ordner liegen.

'Es dürfen sich in diesem Ordner keine weiteren xls-Dateien befinden.

'Alle Dateien (sowohl Quell- als auch Zieldateien müssen absolut dieselbe

'Struktur aufweisen. Insbesondere ist zwingend nötig, dass die Arbeitsblätter

'in allen Dateien dieselben Namen aufweisen.

'Die Prozedur prüft in der Sammeldatei, welche Zellen nicht geschützt sind und

'holt aus den Quelldateien aus denselben entsprechenden Zellen die numerischen

'Inhalte und addiert sie in der Zieldatei dazu.





Dim xls As String

Dim str_Sammelordner As String

Dim wb As Workbook

Dim extwb As Object

Dim wsh As Worksheet

Dim ur As Range

Dim c As Range





Sub Gesamtstatistik_Erstellen()



Set wb = ActiveWorkbook

str_Sammelordner = ActiveWorkbook.Path



If Right(wb.Name, 10) "Sammel.xls" Then



'Die Sammeldatei sollte grundsätzlich den Namen "Sammel.xls" haben.

'Wenn dies nicht der Fall ist, wird der Benutzer darauf hingewiesen

'Er kann dann wählen, ob das ignoriert oder abgebrochen werden soll.

If MsgBox("Ist die aktuelle Datei (" & wb.Name & ") die richtige Sammeldatei?", _

vbYesNo, "Zielüberprüfung") = vbNo Then

Application.StatusBar = "Bearbeitung abgebrochen!"

Beep

Exit Sub

End If



End If



'Die Sammeldatei wird zunächst leergemacht

Call Gesamtstatistik_Leeren



'Dann werden die Worksheets durchlaufen,

For Each wsh In wb.Worksheets



'der benutzte Bereich näher untersucht

Set ur = wsh.UsedRange



'und zwar wird bei jeder Zelle,

For Each c In ur.Cells



'die nicht gesperrt ist,

If c.Locked = False Then



'der Zellinhalt gelöscht

c = ""



End If



Next



Next



'Dann werden die Daten aus den übrigen Dateien geholt



'Dazu wird ermittelt, welche xls-Dateien im Sammelordner sind

xls = Dir(str_Sammelordner & "\*.xls")



'Wenn eine Datei gefunden wird

While xls ""



'und es sich dabei nicht um die Sammeldatei handelt,

If xls wb.Name Then



'wird eine Verbindung zu der Datei hergestellt.

Set extwb = GetObject(str_Sammelordner & "\" & xls)

Application.StatusBar = "Dateien aus " & xls & " werden addiert!"



'Anschliessend werden im Ziel alle Worksheets durchlaufen

For Each wsh In wb.Worksheets



'und der benutzte Bereich näher untersucht.

Set ur = wsh.UsedRange



'Bei jeder Zelle wird,

For Each c In ur.Cells



'wenn sie nicht gesperrt ist,

If c.Locked = False And IsNumeric(c) Then



'aus der aktuellen Quelle der darin gespeicherte Wert

'zu der Zielzelle hinzuaddiert

'Zelle in der Sammeldatei dazuaddiert

c = extwb.Worksheets(wsh.Name).Range(c.Address) + c



End If

Next

Next

End If



'Dann wird die nächste Datei gesucht

xls = Dir



Wend



'Am Schluss wird die noch bestehende Verbindung gekappt

Set extwb = Nothing



End Sub



Sub Gesamtstatistik_Leeren()



'Die Sammeldatei wird zunächst leergemacht



'Dazu werden die Worksheets durchlaufen,

For Each wsh In ActiveWorkbook.Worksheets



'der benutzte Bereich näher untersucht

Set ur = wsh.UsedRange



'und zwar wird bei jeder Zelle,

For Each c In ur.Cells



'die nicht gesperrt ist,

If c.Locked = False Then



'der Zellinhalt gelöscht

c = ""



End If



Next



Next



End Sub



Viel Erfolg

Manes
Ob ich Spotlight gut finde? Also wenn ich ehrlich sein soll, müsste ich lügen!

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: