VBA Lösung-Werte zusammenfassen

Bea · 2016-07-17T16:03:17+00:00

Hallo, ich benötige mal wieder Hilfe :-( und sag im Voraus wie immer wieder DANKE. Ich habe 5 sheets in denen Werte ermittelt werden aus einer Liste. Die so ermittelten Werte möchte ich gerne per VBA in einem sheet "Übersicht" addieren und zusammengefasst darstellen. Beispiel: Tabellenblatt 1 A - B - C - D 12 68 12 12 Tabellenblatt 2: A - B - C - D 80 16 5 31 Tabellenblatt Übersicht: A - B - C - D 92 84 17 33 Hoffe das verständlich erklärt zu haben. Und nun warte ich da ich eh nicht mehr richtig fündig werde im world wide web. Grüße Bea

Hi Bea,
im Nachhinein ist mir noch ein Schwachpunkt eingefallen, den ich nicht berücksichtigt hatte: die Zuweisung erfolgt momentan NUR zu einem Array (das ist NICHT die Zeile, in der es hakelt), wenn der Bereich MEHR als eine Zelle umfaßt; wenn es sich um eine einzelne Zelle handelt (also z.B. C3), ist das Ergebnis kein Array, sondern ein einzelner Wert: dann kommt spätestens bei ubound(wb(i)) ein Fehler.
Warum bei Dir bereits vorher ein Fehler kommt, könnte daran liegen, daß Du mehrere Bereiche in einer Zelle zusammenfaßt. Arrays können nur aus EINEM zusammenhängenden Bereich erzeugt werden.
D.h. "D2:E4" ist unproblematisch, aber eine "normale" Range-Zuweisung wie z.B.
Range("A2:D4,E6:F8") mit mehreren Bereich geht bei Arrays NICHT.
Das müßtest Du dann in zwei Zeilen schreiben: A2:D4 und E6:F8 - Zeilen hast Du ja beliebig viele zur Verfügung.
Also, ich habe jetzt den Fall einer EINZELNEN Zelle berücksichtigt und getestet. Das mit dem nicht zusammenhängenden Bereich wäre mehr Aufwand als die Sache wert ist.
Makro:

Option Explicit
Sub zamzaehlen()
Dim blatt As String
Dim sh As Worksheet
Dim maxZ As Long, i As Long, s As Long, z As Long
Dim b ' wie Bereiche
Dim w0, wb ' wie Werte; 0 = Übersicht, b wie Blatt
blatt = Range("M3")
maxZ = Range("M" & Rows.Count).End(xlUp).Row
If maxZ  0 Or _
InStr(b(i, 2), ",") > 0 Then
MsgBox "Komma vorhanden: geht leider nicht mit mehreren Bereichen in Einem."
Exit Sub
End If
If (Range(b(i, 1)).Rows.Count  Range(b(i, 2)).Rows.Count) Or _
(Range(b(i, 1)).Columns.Count  Range(b(i, 2)).Columns.Count) Then
MsgBox "Zeilen und/oder Spalten unterschiedlich"
Exit Sub
End If
Next
' ************* BEVOR was geleert wird
ReDim w0(0 To UBound(b))
ReDim wb(0 To UBound(b))
For i = 1 To UBound(b)
Range(b(i, 1)).ClearContents
w0(i) = Range(b(i, 1))
Next
For Each sh In Worksheets
If Mid(sh.Name, 1, Len(blatt)) = blatt Then
For i = 1 To UBound(b)
wb(i) = sh.Range(b(i, 2))
If sh.Range(b(i, 1)).Count = 1 Then
w0(i) = w0(i) + wb(i)       ' einzelne Zelle
Else
For z = 1 To UBound(wb(i))  ' Schleife für mehrere = Array
For s = 1 To UBound(wb(i), 2)
w0(i)(z, s) = w0(i)(z, s) + wb(i)(z, s)
Next
Next
End If
Next
End If
Next
For i = 1 To UBound(b)
Range(b(i, 1)) = w0(i)
Next
End Sub

Datei: https://www.herber.de/bbs/user/107085.xlsm
Sollte bei Dir noch ein Fehler auftreten, kopiere bitte die Liste der Bereiche mal hier rein.
Schöne Grüße,
Michael

Hallo Bea,
Michael hat dir ja schon eine wirklich ausgefuchste Lösung geliefert!
Hier nur der Vollständigkeit halber meine Bastelvariante, angepasst auf deine Musterdatei.
LG; Christian

Option Explicit
Option Base 1
Sub Addieren()
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim intMaxSheet
Dim myArr As Variant
Dim r, c As Integer
'' Bereich C2:F8
ReDim myArr(2 To 8, 3 To 6)
Set wb = ThisWorkbook
intMaxSheet = 5
For Each ws In wb.Worksheets
If Not ws.Name = "Übersicht" Then
For r = LBound(myArr) To UBound(myArr)
For c = LBound(myArr, 2) To UBound(myArr, 2)
myArr(r, c) = myArr(r, c) + ws.Cells(r, c).Value '.Offset(1, 0).Value
Next c
Next r
End If
Next
'Werte Schreiben in Blatt 'Übersicht'
wb.Worksheets("Übersicht").Range("C6:F12").Value = myArr
''Bereich D19:F21
ReDim myArr(19 To 21, 4 To 6)
For Each ws In wb.Worksheets
If Not ws.Name = "Übersicht" Then
For r = LBound(myArr) To UBound(myArr)
For c = LBound(myArr, 2) To UBound(myArr, 2)
myArr(r, c) = myArr(r, c) + ws.Cells(r, c).Value '.Offset(1, 0).Value
Next c
Next r
End If
Next
'Werte Schreiben in Blatt 'Übersicht'
wb.Worksheets("Übersicht").Range("D23:F25").Value = myArr
End Sub

Forumthread: VBA Lösung-Werte zusammenfassen

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

VBA-Lösung zum Zusammenfassen von Werten in Excel

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)