Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema TextBox
BildScreenshot zu TextBox TextBox-Seite mit Beispielarbeitsmappe aufrufen

Markierungsweite berechnen

Betrifft: Markierungsweite berechnen von: Sparrow
Geschrieben am: 11.11.2014 09:59:58

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

  

Betrifft: AW: Markierungsweite berechnen von: Rudi Maintaire
Geschrieben am: 11.11.2014 11:22:06

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 < Columns.Count
      Set cRight = cRight.Offset(, 1)
    Loop
    Set cBottom = cRight
    Do While cBottom.Borders(xlBottom).LineStyle = xlNone And cBottom.Row < Rows.Count
      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
  x = Ranges(myRange, vbCr)
  x = Split(x, vbCr)
  For i = 0 To UBound(x)
  DieSumme = DieSumme + WorksheetFunction.Sum(Range(x(i))) / Range(x(i)).Columns.Count
  Next
End Function

Gruß
Rudi


  

Betrifft: AW: Markierungsweite berechnen von: Sparrow
Geschrieben am: 11.11.2014 11:47:05

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


  

Betrifft: AW: Markierungsweite berechnen von: Rudi Maintaire
Geschrieben am: 11.11.2014 11:58:53

Hallo,
hab nicht so ganz verstanden was du willst.

Gruß
Rudi


  

Betrifft: AW: Markierungsweite berechnen von: Sparrow
Geschrieben am: 11.11.2014 12:07:24

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


  

Betrifft: AW: Markierungsweite berechnen von: Rudi Maintaire
Geschrieben am: 11.11.2014 14:25:03

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 < Columns.Count
      If cRight.Offset(, 1).Borders(xlLeft).LineStyle <> 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 < Rows.Count
      If cBottom.Offset(1).Borders(xlTop).LineStyle <> 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


  

Betrifft: AW: Markierungsweite berechnen - Hammer! von: Sparrow
Geschrieben am: 11.11.2014 14:45:54

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


  

Betrifft: AW: Markierungsweite berechnen - Hammer! von: Sparrow
Geschrieben am: 11.11.2014 14:50:11

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


  

Betrifft: AW: Markierungsweite berechnen - Hammer! von: Rudi Maintaire
Geschrieben am: 11.11.2014 15:32:09

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 < Columns.Count
      If cRight.Offset(, 1).Borders(xlLeft).LineStyle <> 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 < Rows.Count
      If cBottom.Offset(1).Borders(xlTop).LineStyle <> 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


  

Betrifft: AW: Markierungsweite berechnen - Hammer! von: Sparrow
Geschrieben am: 13.11.2014 10:17:14

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


  

Betrifft: AW: Markierungsweite berechnen - Hammer! von: Rudi Maintaire
Geschrieben am: 13.11.2014 12:34:46

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


 

Beiträge aus den Excel-Beispielen zum Thema "Markierungsweite berechnen"