Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1388to1392
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Markierungsweite berechnen

Markierungsweite berechnen
11.11.2014 09:59:58
Sparrow
Hallo!
Zunächst ist es von Vorteil wenn nebenbei die Beispieldatei geöffnet ist - in dieser befinden sich Balken welche Zeitabhängig Beispielwerte über eine gewisse Zeit angeben. Ich suche nun eine VBA-Lösung welche mir ermöglicht, dass ich - wie in der Beispieldatei - verschiedene Teile von mehreren Balken mit der Maus markiere und mir dementsprechend die Summe unten rechts in Excel oder in einer MessageBox ausgegeben wird. In der Datei wäre das also 2800*1/3 + 3528*1/3 + 784*1/3 = 757 -- Dieser Wert wird unten rechts angezeigt wo auch die normale Summe gebildet wird.
Ist es möglich dies über VBA zu realisieren?
Ein Versuch ist bereits in VBA existent, dieser berechnet allerdings immer nur 1/3 des Balkens - dazu wird nur ein Wert gezeigt, wenn ich direkt die Zelle mit der Zahl markieren, es soll aber auch ein Wert ausgegeben werden wenn sich diese Zahl lediglich in dem Balken befindet - also auch bpsw. rechts daneben!
Vielen vielen Dank im Voraus!
https://www.herber.de/bbs/user/93666.xlsm
Vg
Sascha

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Markierungsweite berechnen
11.11.2014 11:22:06
Rudi
Hallo,
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MsgBox DieSumme(Selection)
End Sub

In ein Modul:
Function Ranges(r As Range, strDelim As String) As String
Dim c As Range, cLeft As Range, cRight As Range, cTop As Range, cBottom As Range
For Each c In r
If Not Intersect(ActiveSheet.UsedRange, c) Is Nothing Then
Set cLeft = c
Do While cLeft.Borders(xlLeft).LineStyle = xlNone And cLeft.Column > 1
Set cLeft = cLeft.Offset(, -1)
Loop
Set cTop = cLeft
Do While cTop.Borders(xlTop).LineStyle = xlNone And cTop.Row > 1
Set cTop = cTop.Offset(-1)
Loop
Set cRight = c
Do While cRight.Borders(xlRight).LineStyle = xlNone And cRight.Column 

Gruß
Rudi

Anzeige
AW: Markierungsweite berechnen
11.11.2014 11:47:05
Sparrow
Hey,
schon mal vielen Dank Rudi!
Allerdings gibt er mir, wenn ich bspw. die Mitte von 784 € auswähle, den Wert "1152" aus - erhältst du 1/3 von 784€, also 261€ für den Dezember 2013? Falls ich mich ungenügend erkläre sag Bescheid!
Nochmals vielen Dank im Voraus
Vg
Sascha

AW: Markierungsweite berechnen
11.11.2014 11:58:53
Rudi
Hallo,
hab nicht so ganz verstanden was du willst.
Gruß
Rudi

AW: Markierungsweite berechnen
11.11.2014 12:07:24
Sparrow
Hey,
versteh ich, ist auch etwas komplizierter...
Betrachte man bspw. die 784,00€ - diese erstreckt sich von Nov. 13 - Jan. 14. Nun möchte ich, dass wenn ich die Mitte des Balkens markiere (Der Zellenverbund rechts neben 784€) nur 1/3 der Zahl ausgegeben haben. Denn 784€ gilt für Nov, Dez. und Januar - markiere ich aber nur den Dez. sind es dementsprechend nur 33%. Dies soll aber auch Zeilenübergreifend funktionieren - markiere ich dazu die Mitte von 3528€ sollen die 33% dazu gerechnet werden (784*1/3+3528*1/3). Markiere ich beide Zellenverbunde neben der 784€ sollen dementsprechend 784*2/3 wiedergegeben werden, ziehe ich die Markierung hoch zur 3528€ soll 784*2/3+3528*2/3 wiedergegeben werden..etc.
Sorry, besser kann ich es nicht erläutern! Wegen der Komplexität dieser Aufgabe wäre ich für eine Lösung super dankbar!
Vg
Sascha

Anzeige
AW: Markierungsweite berechnen
11.11.2014 14:25:03
Rudi
Hallo,
endlich mal was ein bisschen anspruchsvolleres.
Schau mal ob das passt:
Function Ranges(myRange As Range, strDelim As String) As String
Dim c As Range, cLeft As Range, cRight As Range, cTop As Range, cBottom As Range
For Each c In myRange
If Not Intersect(ActiveSheet.UsedRange, c) Is Nothing Then
Set cLeft = c
Do While cLeft.Borders(xlLeft).LineStyle = xlNone And cLeft.Column > 1
If cLeft.Offset(, -1).Borders(xlRight).LineStyle  xlNone Then
Exit Do
End If
Set cLeft = cLeft.Offset(, -1)
Loop
Set cTop = cLeft
Do While cTop.Borders(xlTop).LineStyle = xlNone And cTop.Row > 1
If cTop.Offset(-1).Borders(xlBottom).LineStyle  xlNone Then
Exit Do
End If
Set cTop = cTop.Offset(-1)
Loop
Set cRight = c
Do While cRight.Borders(xlRight).LineStyle = xlNone And cRight.Column  xlNone Then
Exit Do
End If
Set cRight = cRight.Offset(, 1)
Loop
Set cBottom = cRight
Do While cBottom.Borders(xlBottom).LineStyle = xlNone And cBottom.Row  xlNone Then
Exit Do
End If
Set cBottom = cBottom.Offset(1)
Loop
If cBottom.Row = Rows.Count Or cBottom.Column = Columns.Count Then
Else
If Ranges = "" Then
Ranges = Range(cTop, cBottom).Address
Else
If InStr(Ranges, Range(cTop, cBottom).Address) = 0 Then
Ranges = Ranges & strDelim & Range(cTop, cBottom).Address
End If
End If
End If
End If
Next
End Function
Function DieSumme(myRange As Range)
Dim x, i As Integer, r As Range, a As Range
x = Ranges(myRange, vbCr)
x = Split(x, vbCr)
For Each a In myRange.Cells
If r Is Nothing Then
Set r = a
Else
Set r = Union(r, a)
End If
Next a
For i = 0 To UBound(x)
For Each a In r.Areas
If Not Intersect(Range(x(i)), a) Is Nothing Then
DieSumme = DieSumme _
+ WorksheetFunction.Sum(Range(x(i))) _
/ Range(x(i)).Columns.Count _
* Intersect(Range(x(i)), a).Columns.Count
End If
Next
Next i
End Function

Funktioniert nicht mit verbundenen Zellen!!!
Orientiert sich allein an den Rahmen.
Gruß
Rudi

Anzeige
AW: Markierungsweite berechnen - Hammer!
11.11.2014 14:45:54
Sparrow
Das ist verdammt gut!
Das einzige was noch optimierungsfähig ist, ist die Rechenzeit - markiere ich bei 1050 bis zum Ende rechnet er ne Ewigkeit - wohl weil dort kein Rahmen verfügbar ist und er ewig weit sucht? Das wäre aber nicht so das Problem, dann achte ich eben darauf dass überall Rahmen existieren! Vielen vielen Dank!!!
Beste Grüße
Sascha

AW: Markierungsweite berechnen - Hammer!
11.11.2014 14:50:11
Sparrow
Nachtrag -
Ggf. könnte man ihm sagen dass es pro Wert max. 3 Spalten sind und er nicht unendlich weitersuchen soll? Nochmals vielen Dank für die Hammer Lösung!
Beste Grüße
Sascha

AW: Markierungsweite berechnen - Hammer!
11.11.2014 15:32:09
Rudi
Hallo,
Einschränkung von rechts und unten auf UsedRange:
Function Ranges(myRange As Range, strDelim As String) As String
Dim c As Range, cLeft As Range, cRight As Range, cTop As Range, cBottom As Range
For Each c In myRange
If Not Intersect(ActiveSheet.UsedRange, c) Is Nothing Then
Set cLeft = c
Do While cLeft.Borders(xlLeft).LineStyle = xlNone And cLeft.Column > 1
If cLeft.Offset(, -1).Borders(xlRight).LineStyle  xlNone Then
Exit Do
End If
Set cLeft = cLeft.Offset(, -1)
Loop
Set cTop = cLeft
Do While cTop.Borders(xlTop).LineStyle = xlNone And cTop.Row > 1
If cTop.Offset(-1).Borders(xlBottom).LineStyle  xlNone Then
Exit Do
End If
Set cTop = cTop.Offset(-1)
Loop
Set cRight = c
Do While cRight.Borders(xlRight).LineStyle = xlNone And cRight.Column  xlNone Then
Exit Do
End If
If Intersect(cRight, ActiveSheet.UsedRange) Is Nothing Then Exit Do
Set cRight = cRight.Offset(, 1)
If Intersect(cRight, ActiveSheet.UsedRange) Is Nothing Then
Set cRight = cRight.Offset(, -1)
Exit Do
End If
Loop
Set cBottom = cRight
Do While cBottom.Borders(xlBottom).LineStyle = xlNone And cBottom.Row  xlNone Then
Exit Do
End If
Set cBottom = cBottom.Offset(1)
If Intersect(cBottom, ActiveSheet.UsedRange) Is Nothing Then
Set cBottom = cBottom.Offset(-1)
Exit Do
End If
Loop
If cBottom.Row = Rows.Count Or cBottom.Column = Columns.Count Then
Else
If Ranges = "" Then
Ranges = Range(cTop, cBottom).Address
Else
If InStr(Ranges, Range(cTop, cBottom).Address) = 0 Then
Ranges = Ranges & strDelim & Range(cTop, cBottom).Address
End If
End If
End If
End If
Next
End Function
Das kann aber zu falschen Ergebnissen führen. Besser immer Rahmen drum.
Gruß
Rudi

Anzeige
AW: Markierungsweite berechnen - Hammer!
13.11.2014 10:17:14
Sparrow
Hey Rudi,
wirklich eine perfekte Lösung.
Nun soll diese - wie soll es auch anders sein - noch verändert werden. Nun möchte ich nicht dass die Berechnung als Fenster erscheint sondern in einem neuen Tabellenblatt in einer Zelle niedergeschrieben wird - und zwar in Spalte 3, natürlich immer der berechnete Wert der Zelle.
Würdest du mir noch mal helfen?
Vg
Sascha

AW: Markierungsweite berechnen - Hammer!
13.11.2014 12:34:46
Rudi
Hallo,
dazu musst du doch nur das ändern:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
MsgBox DieSumme(Selection)
End Sub

z.B.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sheets(2).cells(rows.count, 3).end(xlup).offset(1) = DieSumme(Selection)
End Sub
Gruß
Rudi
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige