Ist Tabellenübergreifender Bereich keine Range?

Function KreuzSumNum(Bereich As Range) As Variant Dim AllEmpty As Boolean ' Wenn alle Ergebnisse leer sind Dim ErgSum As Double ' Zahlensumme Dim WI1 As Integer Dim Zelle As Object ' Zellen-Objekt für Suche Dim VABer As Range AllEmpty = True ' Annahme, dass alles leer ist ErgSum = 0 ' Summe auf Null stellen For Each Zelle In Bereich WI1 = VarType(Zelle.Value) ' hole den typ If WI1 = vbInteger _ Or WI1 = vbLong _ Or WI1 = vbSingle _ Or WI1 = vbDouble _ Or WI1 = vbCurrency _ Or WI1 = vbDecimal _ Then ErgSum = ErgSum + Zelle.Value ' Zellenwert dazuaddieren AllEmpty = False ' indikator für alles LEER löschen Else ' Wenn kein nummerischer Wert war If Not IsEmpty(Zelle.Value) = True Then AllEmpty = False ' indikator für alles LEER löschen End If End If Next Zelle If AllEmpty Then KreuzSumNum = Empty Else KreuzSumNum = ErgSum End If End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo!
Hab - mangels des fehlenden Range-Objektes - das Problem "zu Fuß" gelöst:
Vielleicht hilft die Lösung jemanden:
'################################################################
' Liefert eine Summe aus einem Bereich über mehrere Tabellen der
' Arbeitsmappe zurück
' Wenn alle Zellen des zu untersuchenden Bereiches leer sind,
' wird NOTHING zurückgegeben
'
' Written by: Johann Kellner (johann.kellner@gmx.at)
' no warranty - keine Garantie für sichere Funktionalität
' Übergabe:
' Tabellenzelle mit der begonnen wird
' Tabellenzelle bis zu der untersucht wird
' Beispiel:
' =StichSumNum(Tabelle3!A2; Tabelle5!C3)
' entspricht: =Sum(Tabelle3!A2:C3;Tabelle4!A2:C3;Tabelle5!A2:C3)
' nur kann man StichSumNum auch auf Istleer(StichSumNum(.....)) abfragen
' Rückgabe
' Summe oder Empty


Function StichSumNum(VonRange As Range, _
BisRange As Range) As Variant
Dim AllEmpty As Boolean     ' Wenn alle Ergebnisse leer sind
Dim ErgSum As Double        ' Zahlensumme
Dim StepWt As Integer       ' Stepwert für Loop
Dim WI1 As Integer          ' Hilfszähler
Dim WL1 As Long             ' Work-Long
Dim WS1 As String           ' Work-String
Dim Zelle As Object ' Zellen-Objekt für Suche
Dim RangeBer As String  ' Bereichsadresse als Text
Dim RangeBerVon As String
Dim RangeBerBis As String
Dim VABer As Range      ' Hilfs-Range
Dim strVon As String    ' Name der Von-Tabelle
Dim strBis As String    ' Name der Bis-Tabelle
Dim VonSheet As Long    ' Index der Von-Tabelle
Dim BisSheet As Long    ' Index der Bis-Tabelle
Dim wks As Worksheet    ' aktives Worksheet
On Error GoTo StichSumErr
strVon = VonRange.Worksheet.Name
VonSheet = VonRange.Worksheet.Index
strBis = BisRange.Worksheet.Name
BisSheet = BisRange.Worksheet.Index
RangeBerVon = VonRange.Address(ReferenceStyle:=xlA1, _
RowAbsolute:=False, _
ColumnAbsolute:=False)  ' Rangebereich als Text holen
RangeBerBis = BisRange.Address(ReferenceStyle:=xlA1, _
RowAbsolute:=False, _
ColumnAbsolute:=False)  ' Rangebereich als Text holen
If RangeBerVon = RangeBerBis Then   ' Wenn Von- und Bis-Range gleich sind
RangeBer = RangeBerVon          ' wird akzeptiert
Else
If InStr(RangeBerVon, ":") > 0 Or InStr(RangeBerBis, ":") > 0 Then
StichSumNum = "Ungültiger Aufruf: Von und Bis darf nur eine Zelle sein und kein Bereich!"
Exit Function
Else
RangeBer = RangeBerVon & ":" & RangeBerBis  ' eine von-bis-Range bilden
End If
End If
If VonSheet > BisSheet Then
StepWt = -1
Else
StepWt = 1
End If
AllEmpty = True             ' Annahme, dass alles leer ist
ErgSum = 0                  ' Summe auf Null stellen
For WL1 = VonSheet To BisSheet Step StepWt  ' Alle Tabellen durchgehen
Set wks = ActiveWorkbook.Worksheets(WL1)    ' Worksheet-Objekt setzen
Set VABer = wks.Range(RangeBer)     ' Range-Objekt bilden
For Each Zelle In VABer             ' Jede Zelle der Tab-Bereiches durchgehen
WI1 = VarType(Zelle.Value)        ' hole den typ
If WI1 = vbInteger _
Or WI1 = vbLong _
Or WI1 = vbSingle _
Or WI1 = vbDouble _
Or WI1 = vbCurrency _
Or WI1 = vbDecimal _
Then                          ' Wenn es ein Zahlenwert ist
ErgSum = ErgSum + Zelle.Value   ' Zellenwert dazuaddieren
AllEmpty = False        ' indikator für alles LEER löschen
Else      ' Wenn kein nummerischer Wert war
If Not IsEmpty(Zelle.Value) = True Then
AllEmpty = False        ' indikator für alles LEER löschen
End If
End If
Next Zelle
Next WL1
If AllEmpty Then            ' Wenn keine untersuchte Zelle einen Wert enthielt
StichSumNum = Empty     '   wird Leer zurückgegeben
Else                        ' Wenn Wert enthalten war
StichSumNum = ErgSum    '   Wird die Summe zurückgegeben
End If
Exit Function
StichSumErr:
StichSumNum = Error                 ' Fehlerabbruch
Exit Function
End Function

Beliebteste Forumthreads (12 Monate)

Ist Tabellenübergreifender Bereich keine Range?

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ist Tabellenübergreifender Bereich keine Range?

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread