VBA Lösung-Werte zusammenfassen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Bea,
warum sagst Du dann eingangs, es geht um A2:D6 mit 5 Blättern?
Die Anzahl der Tabellenblätter ist nicht das Thema, das geht mit Schleife, ob es 5 oder 50 sind.
Nur: woher soll Excel wissen, welche Spalten bzw. Zeilen "interessant" sind?
Da gibt es mehrere Möglichkeiten: nach Überschriften in Spalten/Zeilen suchen, vorab pro Datei eine "Struktur" festlegen, die dann ausgelesen wird usw.
Wie stellst Du Dir das vor?
Nochmal zur Klärung: die "Übersicht" soll in jeder Datei getrennt erstellt werden? So daß das Makro jede Datei öffnet, die Übersicht anlegt und durchrechnet und die Datei dann speichert?
Ich fürchte, ohne anonymisierte Beispieldatein ist die Fragestellung zu schwammig.
Hm. Eine mit überschaubarem Aufwand zu programmierende Geschichte wäre, wenn Du die Übersicht jeweils händisch anlegst und die Zellen, die summiert werden sollen, irgendwie "markierst", indem Du z.B. "#hier" reinschreibst oder -123.
Schöne Grüße,
Michael

Option Explicit Option Base 1 Sub Addieren() Dim i As Integer Dim wb As Workbook Dim intMaxSheet Dim myArr As Variant Dim r, c As Integer ReDim myArr(1 To 6, 1 To 4) Set wb = ThisWorkbook intMaxSheet = 5 For i = 1 To intMaxSheet For r = LBound(myArr) To UBound(myArr) For c = LBound(myArr, 2) To UBound(myArr, 2) myArr(r, c) = myArr(r, c) + wb.Worksheets("Tabelle" & i).Cells(r, c).Offset(1, _ 0).Value Next c Next r Next i wb.Worksheets("Übersicht").Range("A2:D6").Value = myArr End Sub

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

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

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

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

Beliebteste Forumthreads (12 Monate)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread