Funktion gesucht

Bild

Betrifft: Funktion gesucht von: Lorenz
Geschrieben am: 04.03.2005 14:19:03

Hallo zusammen!

Habe folgendes Problem:
Ich möchte aus einer Zeichenkette heraus "1 Birne, 12 Äpfel, 22 Bananen, 12 Birnen,..." die Ziffernsumme bilden z. b. =Summe="47".

Des weiteren möchte ich aus mehreren Blättern mit einer Benutzerdefinierten Funktion eine 3D Summe bilden. Und zwar aus selbiger Zeichenkette =SUMME(Tabelle1"Äpfel"+Tabelle2"Äpfel"+....)

Kann mir vielleicht jemand dabei helfen?
Danke im voraus Lorenz!

Bild


Betrifft: zum ersten Punkt von: Andi
Geschrieben am: 04.03.2005 14:43:46

Hi Lorenz,

mit folgender benutzerdefinierten Funktion sollte der erste Aufgebenteil gelöst sein:

Function obst_zaehlen(zelle As Range) As Double
Dim zaehler As Integer
Dim zahl As String
For zaehler = 1 To Len(zelle.Value)
  Select Case Mid(zelle.Value, zaehler, 1)
    Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
      zahl = zahl & Mid(zelle.Value, zaehler, 1)
    Case Else
      obst_zaehlen = obst_zaehlen + Val(zahl)
      zahl = ""
    End Select
Next zaehler
End Function


Das funktioniert in der Form aber nur bei ganzen Zahlen, Dezimalzahlen werden nicht richtig verarbeitet. Deshalb, und weil ich für den zweiten Teil nix hab, noch offen...

Schönen Gruß,
Andi


Bild


Betrifft: AW: zum zweiten Punkt von: Martin Beck
Geschrieben am: 04.03.2005 14:53:19

Hallo Andi,

wenn es immer die geiche Zelle in jeder Tabelle wäre, müßte man in Deine Funktion noch eine Schleife über die Tabellenblätter einfügen, und dann müßte es das doch tun, oder?

Gruß
Martin Beck


Bild


Betrifft: AW: zum zweiten Punkt von: Andi
Geschrieben am: 04.03.2005 15:27:14

Hi Martin,

ich hab Deinen Vorschlag mal umgesetzt:

Function obst_zaehlen(zelle As Range) As Double
Dim tabellen_zaehler As Integer
Dim zaehler As Integer
Dim zahl As String
Dim zeile As Integer
Dim spalte As Integer
For tabellen_zaehler = 1 To ActiveWorkbook.Worksheets.Count
For zaehler = 1 To Len(Worksheets(tabellen_zaehler).Cells(zelle.Row, zelle.Column).Value)
  Select Case Mid(Worksheets(tabellen_zaehler).Cells(zelle.Row, zelle.Column).Value, zaehler, 1)
    Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
      zahl = zahl & Mid(Worksheets(tabellen_zaehler).Cells(zelle.Row, zelle.Column).Value, zaehler, 1)
    Case Else
      obst_zaehlen = obst_zaehlen + Val(zahl)
      zahl = ""
    End Select
Next zaehler
Next tabellen_zaehler
End Function


Geht aber nur, wenn der String auf jedem Blatt in der gleichen Zelle steht. Außderdem bemerkt die Formel leider nur Änderungen auf dem Blatt, auf dem sie steht, wenn sie also auf Tabelle1 steht und ich ändere in Tabelle2 die Anzahl der Birnen, dann wirkt sich das nicht aus. Auch nicht bei manueller Neuberechnung, sondern nur, wenn die Funktion neu eingegeben wird. Keine Ahnung woran das liegt, ich hab noch nie ne Funktion geschrieben, die mit nur einer Zelle als Argument über mehrere Blätter ging.

Eine andere Option wäre natürlich, jeden einzelne Zelle, in der so ein String steht, als eigenes Argument an die Funktion zu übergeben, dann müsste ich aber vorher wissen, wieviele das sind (zumindest müsste ich die Obergrenze kennen), weil das ja kein zusammenhängender Bereich ist.

Schönen Gruß,
Andi


Bild


Betrifft: AW: zum zweiten Punkt von: Martin Beck
Geschrieben am: 04.03.2005 15:56:00

Hallo Andi,

schön. Die Übergabe beliebige vieler einzelner Zellen könnte man m.E. mit ParamArray hinbekommen. Und hinsichtlich der Neuberechnung hilft vielleicht Application.Volatile am Anfang.

Muß jetzt gleich weg und kann es nicht mehr ausprobieren, aber vielleicht packst Du's nochmal an. ;-)

Gruß
Martin Beck


Bild


Betrifft: AW: zum zweiten Punkt von: Andi
Geschrieben am: 04.03.2005 16:04:08

Danke für den Hinweis, Martin,

mit Application.Volatile geht's jetzt.

ParamArray ist auch ne gute Idee, werd ich auf jeden Fall noch ausprobieren und mich dann hier nochmal melden, muss jetzt aber erst mal wieder ein bisschen arbeiten :-)

Schönen Gruß,
Andi


Bild


Betrifft: AW: zum zweiten Punkt von: Andi
Geschrieben am: 04.03.2005 16:54:40

Hi nochmal,

folgende Funktion kommt jetzt mit beliebig vielen Zellen auf beliebig vielen Blättern klar; vielen Dank für Deine Inputs, Martin, hab wieder was gelernt (ParamArray).
Nur eine Sache stört mich noch bei der Funktion, nämlich die case-Abfrage. Hast Du vielleicht ne Idee, wie man das eleganter hinbekommen könnte, als alle Ziffern einzeln abzufragen? Mit IsNumber bin ich da irgendwie nicht weitergekommen...

Function obst_zaehlen(ParamArray zellen() As Variant) As Double
Application.Volatile
Dim zaehler As Integer
Dim zahl As String
Dim zelle As Variant
For Each zelle In zellen()
For zaehler = 1 To Len(zelle.Value)
  Select Case Mid(zelle.Value, zaehler, 1)
    Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
      zahl = zahl & Mid(zelle.Value, zaehler, 1)
    Case Else
      obst_zaehlen = obst_zaehlen + Val(zahl)
      zahl = ""
    End Select
Next zaehler
Next zelle
End Function



Einen schönen Feierabend & ein schönes Wochenende wünscht
Andi


Bild


Betrifft: AW: zum zweiten Punkt von: Lorenz
Geschrieben am: 04.03.2005 17:10:02

Hallo Andi!

zum zweiten Punkt habe ich mich scheinbar etwas schlecht ausgedrückt!

gesucht ist : wenn im (Tab1A1 "12Äpfel, 15 Birnen" in Tab2A1 "3Äpfel, 2 Birnen"), so möchte ich zb in einen SummenBlatt =SUMME(Tab1"Äpfel";Tab2"Äpfel";))"= 15" oder =SUMME(Tab1"Birnen";Tab2"Birnen";))"= 17" wobei Äpfel ect. als Parameter angegeben werden kann. Ich hoffe so ist rübergekommen.

PS: deine gelieferte Function (die ausgezeichnet funktioniert) kann ich aber trotzdem für andere Bereiche verwenden!

viele Grüsse Lorenz


Bild


Betrifft: AW: zum zweiten Punkt von: Andi
Geschrieben am: 04.03.2005 18:05:49

Hi Lorenz,

ja, jetzt hab ich die Aufgabenstelleung verstanden.
Leider werd' ich vor Sonntag Nachmittag oder Montag nicht dazukommen, mich damit zu beschäftigen. Ich meld mich aber auf jeden Fall wieder.

Schönes Wochenende,
Andi


Bild


Betrifft: AW: zum zweiten Punkt von: Luc
Geschrieben am: 04.03.2005 15:46:28

Hallo Lorenz,
bist du der, dem ich neulich mal helfen wollte, ich glaub es ging auch über mehrere Tabellenblätter hinweg und INDIREKT hat's nicht gemacht. Inzwischen hab ich eine Funktion geschrieben, die INDIREKT ersetzt und das was du wolltest und noch mehr kann. Hatte ich auch noch an den alten Thread geschrieben (jetzt ist der im Archiv), aber du dachtest, das ist erledigt und hast nicht noch mal nachgesehen. Sollte man aber tuen, manchmal ergibt sich doch noch was.
Bei Interesse melde dich hier, schalte jetzt ab.
Ciao Luc


Bild


Betrifft: AW: zum zweiten Punkt von: Lorenz
Geschrieben am: 04.03.2005 16:48:47

Hallo Luc!
Genau dieser Lorenz bin ich.
Selbstverständlich besteht noch Interesse! Es ist genau wie du sagtest "als erledigt gesehen u. nicht mehr nachgeschaut"

viele Grüsse Lorenz


Bild


Betrifft: AW: zum zweiten Punkt von: Luc :-?
Geschrieben am: 04.03.2005 19:59:23

Na das ist ja schön Lorenz,
ich dachte schon, hier wär's für dich auch schon wieder vorbei. Ich überlasse dir hier die Beta-Version meiner Ersatzfunktion für INDIREKT. Ich hatte ja angedeutet, dass ich schon mal sowas für meine Zwecke geschrieben hatte, die wurde aber mit deinem Problem nicht fertig. Die neue schafft das und noch ein bisschen mehr, allerdings dürfte sie Pfadangaben und Mehrfachauswahlen nicht beherrschen, was die andere gekonnt hätte. Aber ich hab sie inzwischen auch auf diese nichtzusammenhängenden (Mehrfachauswahl-)Bereiche erweitert, sie braucht dann aber noch andere selbstgeschriebene Funktionen und das geht dann schon etwas zu weit. Aber für deine Zwecke (getestet) reicht sie ja so wie folgt:

Function TinRange(ByVal BezText As Variant, Optional ByVal unsichtBl As Variant) As Variant
'   Ersatz für INDIREKT() - Umwandlung eines (Bezugs auf einen) Bezugstext in einen Bereichsbezug -
'   nur für Einfachauswahl zushängd gleicher Zellbereiche mehrerer aufeinanderff ArbBl nur einer Datei
'   unter Auslassung/Einbeziehung (unsichtBl=fehlt|0/1) in der ArbBlFolge auftretd versteckter Blätter 
'   Autor: L.Schuller - Version 1.2 beta - Erstpublikation: 20050304 auf Herbers-Excel-Server
    Dim bz(2) As String, zz As String, i As Integer, n As Integer, mz As Boolean, _
        j As Long, k As Long, m As Long, x As Worksheet, y() As Variant, z() As Variant
    Const SZ = ":\[]'!"                                                 'mögl SonderZ in Zellbezügen
    On Error GoTo fx
    If IsError(BezText) Then Exit Function
    If IsMissing(unsichtBl) Then
        unsichtBl = False
    Else: unsichtBl = CBool(unsichtBl)
    End If
    If IsEmpty(BezText) Then Exit Function
    If InStr(BezText, Right(SZ, 1)) Then
        bz(0) = Left(BezText, InStr(BezText, Right(SZ, 1)) - 1)
    End If
    bz(0) = WorksheetFunction.Substitute(bz(0), Mid(SZ, 5, 1), "")      'Entfernen störend 'Begrenzer'
    zz = Mid(BezText, InStr(BezText, Right(SZ, 1)) + 1)
    mz = InStr(zz, Left(SZ, 1))
    With ActiveWorkbook
        If bz(0) = "" Then
            Set TinRange = ActiveSheet.Range(zz)
        ElseIf InStr(bz(0), Left(SZ, 1)) > 0 Then
            bz(1) = Left(bz(0), InStr(bz(0), Left(SZ, 1)) - 1)
            bz(2) = Mid(bz(0), InStr(bz(0), Left(SZ, 1)) + 1)
            n = .Sheets(bz(2)).Index - .Sheets(bz(1)).Index
            m = Range(zz).Cells.Count
            If mz Then
                n = (n + 1) * m - 1
            End If
            ReDim y(n) As Variant
            For Each x In .Sheets
                If x.Index > .Sheets(bz(2)).Index Then Exit For
                If x.Index >= .Sheets(bz(1)).Index Then
                    If mz Then                                          'ZellErfassung Bereichsbezüge
                        For j = 0 To m - 1
                            If x.Visible = xlSheetVisible Or unsichtBl Then
                                Set y(i * m + j - k) = x.Range(zz).Cells(j + 1)
                            Else: k = k + 1                                 'Zählen entfalld Zellen
                            End If
                        Next j
                    ElseIf x.Visible = xlSheetVisible Or unsichtBl Then 'ZellErfassung Einzelzellen
                        Set y(i - k) = x.Range(zz)
                    Else: k = k + 1                                         'Zählen entfalld Zellen
                    End If
                    i = i + 1
                End If
            Next x
            ReDim z(n - k) As Variant
            For i = 0 To n - k                              'Erstellung Vektor ohne leere Endzellen
                z(i) = y(i)
            Next i
            TinRange = Array(z)
        Else
            TinRange = .Sheets(bz(0)).Range(zz)
        End If
    End With
    Exit Function
fx: Rem Fehlerbehandlung
    TinRange = "F" & Err.Number & ": " & Err.Description
End Function


Weiter viel Erfolg und schönes WE
Luc


Bild


Betrifft: Nachtrag zur INDIREKT-Ersatz-Funktion von: Luc
Geschrieben am: 04.03.2005 20:14:48

So, Lorenz, ich wollte dir noch mitteilen, dass ich die Funktion mit ff.Excel-Arbeitsblattfunktionen positiv getestet habe:
ANZAHL, ANZAHL2, SUMME, PRODUKT, QUADRATESUMME, GEOMITTEL, HARMITTEL, MITTELWERT, KGRÖSSTE, KKLEINSTE, MAX, MAXA, MINA, MIN, MEDIAN, KURT, MITTELABW, SCHIEFE, STABW, STABWA, STABWN, STABWNA, SUMQUADABW, VARIANZ, VARIANZA, VARIANZEN, VARIANZENA, SUMMENPRODUKT
Dabei sind Funktionen, die sich auch bei direkter Angabe sonst nicht auf mehrere Blätter beziehen lassen wie z.B. KKLEINSTE und SUMMENPRODUKT (was eigentlich Produktsumme heißen müsste). Ich hoffe, du weißt wie und wo du die Funktion speichern musst, damit sie dir immer zur Verfügung steht (nicht nur in der einen Arbeitsmappe)!
Ciao Luc :-?


Bild


Betrifft: DANKE zu Nachtrag zur INDIREKT-Ersatz-Funktion von: Lorenz
Geschrieben am: 05.03.2005 12:17:37

Hallo Luc!!

vielen vielen Dank!

PS: "TinRange" wird bereits erfolgreich von mir eingesetzt!

Herzliche Grüsse Lorenz


Bild


Betrifft: Na, das freut mich, Lorenz! Alles Gute! owT von: Luc :-?
Geschrieben am: 05.03.2005 14:06:14




Bild


Betrifft: AW: DANKE zu Nachtrag zur INDIREKT-Ersatz-Funktion von: Andi
Geschrieben am: 07.03.2005 08:35:53

Moin Lorenz,

wenn ich das richtig verstehe, dann ist der zweite Punkt von Luc auch schon zufriedenstellend gelöst worden, oder?
In dem Fall würd ich nämlich, angesichts der Arbeitsmenge hier auf meinem Schreibtisch auf die versprochende Lösung verzichten...

Schönen Gruß,
Andi


Bild


Betrifft: AW: DANKE zu Nachtrag zur INDIREKT-Ersatz-Funktion von: Luc :-?
Geschrieben am: 07.03.2005 14:45:32

Hallo Andi,
bin mir nicht ganz sicher, ob Lorenz mit meiner Funktion auch alle jetzigen Probleme löst. Er hatte die Aufgabe im alten Thread direkter formuliert, deshalb kann ich nicht unbedingt sagen, ob die Äpfel und Birnen das gleiche Problem darstellen. Meine Funktion ersetzt halt in vielen Fällen, wo sie nicht funktioniert, die Fkt INDIREKT. Wenn es hier auch drauf hinausläuft, war's das dann wohl. Also warte am besten ab, ob Lorenz sich noch mal meldet.
Gruß Luc
:-?


Bild


Betrifft: geschlossen von: Andi
Geschrieben am: 08.03.2005 08:42:43

Hi Luc,

danke für die Rückmeldung;
Offenbar kommt Lorenz mit Deiner Formel zurecht, deshalb schliesse ich das hier mal.

Schönen Gruß,
Andi


Bild


Betrifft: AW: zum ersten Punkt von: Lorenz
Geschrieben am: 04.03.2005 15:02:24

Hallo Andi!

Ging ja rucki zucki!

Bingo!!! genau das wars was ich suchte.


vielen vielen Dank
Lorenz


Bild


Betrifft: Gern geschehen... von: Andi
Geschrieben am: 04.03.2005 15:39:45

... freut mich, dass ich helfen konnte.

Bringt Dir die Erweiterung, die ich eben als Antwort auf Martin gepostet habe, was für den zweiten Punkt? Wenn Du das noch angepasst oder modifiziert haben möchtest, meld Dich ruhig nochmal, ansonsten wünsch ich ein schönes Wochenende.

Schönen Gruß,
Andi


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Funktion gesucht"