Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 00:42:03
Listbox mit gefilterten Daten füllen
24.04.2024 20:38:58
Summe mit Bedingung, nur letzte Ergebnisse anzeigen
24.04.2024 19:29:30
Formel filter
24.04.2024 18:49:56
merge & select
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1260to1264
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1260to1264
1260to1264
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Hilfe in VBA

Hilfe in VBA
Michael
Hallo,
ich hatte hier eine Super Lösung meines Problems erhalten, um den Mittelwert eines Bereichs der in mehreren Tagen und Jahren unterteil wurde, für ein bestimmtes Jahr zu erhalten. Leider muss ich den Bereich per Hand angeben. Da dieser sich von Tabellenblatt zu Tabellenblatt ändert ist es mühselig. Gibt es eine Lösung das man die Range automatisch unten in den Code einfügt?
Danke.
VG
Michael 

Function Mittelwert2(intYear As Integer, rngX As Range, rngY As Range)
Dim rngC As Range, objX As Object
Dim arrX, arrY
Set objX = CreateObject("Scripting.Dictionary")
For Each rngC In rngX
If Year(rngC) = intYear Then
objX(rngC.Row) = rngY(rngC.Row - rngY.Row + 1) * 1
End If
Next
arrX = objX.items
Mittelwert2 = WorksheetFunction.Average(arrX)
End Function

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Hilfe in VBA
08.05.2012 14:35:16
Rudi
Hallo,
Gibt es eine Lösung das man die Range automatisch unten in den Code einfügt?
Wie meinst du das?
Gruß
Rudi
AW: Hilfe in VBA
08.05.2012 14:40:42
Michael
Hallo Rudi,
Danke für die Antwort. von Zelle A8 bis zu der letzten gefüllten Zelle sowas in der Art:
Range(Range("A8"), Range("A8").End(xlDown))
Hoffe es ist klarer?
Irgendiwe habe ich keine Lösung das so in meinen Code einzugeben.
VG
Michael
AW: Hilfe in VBA
08.05.2012 14:57:56
Rudi
Hallo,
benutzt du die Funktion in VBA oder in der Tabelle?
Wenn in VBA, kannst du ihn so wie geschrieben an die Funktion übergeben. 
Sub aaa()
Dim rng as Range
Set rng=Range(Range("A8"), Range("A8").End(xlDown))
Msgbox Mittelwert2(2000, rng, rng.OffSet(, 1))  'für Messreihe1
End Sub

Gruß
Rudi
Anzeige
AW: Hilfe in VBA
08.05.2012 15:59:26
Michael
Hallo Rudi,
Danke für die Antwort. Kannst du mir noch sagen wie ich das am besten in meinem Code reinbasteln kann?
VG
Michael
AW: Hilfe in VBA
08.05.2012 16:12:02
Rudi
Hallo,
ich kenn ja deinen Code nicht.
Nebenbei hab ich noch die Fkt. überarbeitet: 
Function Steigung2(intYear As Integer, rngX As Range, rngY As Range)
Dim rngC As Range, objX As Object, objY As Object
Dim arrX, arrY, lngX As Long
arrX = rngX
arrY = rngY
Set objX = CreateObject("Scripting.Dictionary")
Set objY = CreateObject("Scripting.Dictionary")
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
objX(lngX) = arrX(lngX, 1) * 1
objY(lngX) = arrY(lngX, 1) * 1
End If
Next lngX
Steigung2 = WorksheetFunction.Slope(objY.items, objX.items)
End Function

Function Mittelwert2(intYear As Integer, rngX As Range, rngY As Range)
Dim rngC As Range, dblSum As Double, n As Long
Dim arrX, arrY, lngX As Long
arrX = rngX
arrY = rngY
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
n = n + 1
dblSum = dblSum + rngY(lngX, 1)
End If
Next
Mittelwert2 = dblSum / n
End Function

Sub aaa()
Dim rng As Range
Set rng = Range(Cells(8, 1), Cells(8, 1).End(xlDown))
MsgBox Steigung2(2000, rng, rng.Offset(, 1))
End Sub

Sub bbb()
Dim rng As Range
Set rng = Range(Cells(8, 1), Cells(8, 1).End(xlDown))
MsgBox Mittelwert2(2000, rng, rng.Offset(, 1))
End Sub

Das dürfte schneller sein.
Gruß
Rudi
Anzeige
AW: Hilfe in VBA
08.05.2012 16:25:26
Michael
Hallo Rudi,
was ist der Vorteil dieser Funktion im Vergelich zur vorherigen? Kann man in diese Funktion die du oben verwendest nicht noch die Range in einem bestimmten Bereich angeben wie ich das vorher wollte? Also die Einträge fangen immer bei A8 und E8 an und sollten durchgehen bis zur letzten gefüllten Zelle. Daraus folgt das in deiner neuen und alten Funktion in der definition: rngX As Range, rngY As Range rausfallen würde und man es in der Funktion hat. Ist das möglich?
VG
Michael
AW: Hilfe in VBA
08.05.2012 16:41:35
Rudi
Hallo,
der Vorteil liegt in der Geschwindigkeit.
Wenn du es unbedingt unflexibel willst: 
Function Steigung2(intYear As Integer)
Dim objX As Object, objY As Object
Dim arrX, arrY, lngX As Long
arrX = Range(Cells(8, 1), Cells(8, 1).End(xlDown))
arrY = Range(Cells(8, 5), Cells(8, 5).End(xlDown))
Set objX = CreateObject("Scripting.Dictionary")
Set objY = CreateObject("Scripting.Dictionary")
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
objX(lngX) = arrX(lngX, 1) * 1
objY(lngX) = arrY(lngX, 1) * 1
End If
Next lngX
Steigung2 = WorksheetFunction.Slope(objY.items, objX.items)
End Function


Function Mittelwert2(intYear As Integer)
Dim dblSum As Double, lngCount As Long
Dim arrX, arrY, lngX As Long
arrX = Range(Cells(8, 1), Cells(8, 1).End(xlDown))
arrY = Range(Cells(8, 5), Cells(8, 5).End(xlDown))
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
lngCount = lngCount + 1
dblSum = dblSum + rngY(lngX, 1)
End If
Next
Mittelwert2 = dblSum / lngCount
End Function

Gruß
Rudi
Anzeige
AW: Hilfe in VBA
08.05.2012 17:09:49
Michael
Hallo Rudi,
Danke für die Antwort. Es ist noch nicht 100% was ich suche. Wie gesagt habe ich mehrere Tabellenblätter die unterschiedlich lang sind aber immer bei A8 und E8 anfangen. Deshalb bräuchte ich diese Funktion etwas allgemeiner was das Tabellenblatt angeht. Also was ich machen möchte ist wie folgt:
Tabellenblatt Summary holt sich die Daten aus Tabellenblatt 1, 2, 3 und rechnet z.B. die Steigung für Tabellenblatt 1, 2, usw. aus und füllt es wie gesgat in Tabellenblatt Summary. Die Funktion möchte ich aber wie geagt dann selbst in Summary angeben per Hand aber nur die Steigung soll automatisch ausgerechnet werden (hoffe es ist klar was ich möchte?)
VG
Michael
Anzeige
AW: Hilfe in VBA
08.05.2012 17:31:00
Michael
Hallo nochmals,
Also was super wäre ist in der Funktionsdefinition einfach das Tabellenblatt und das Jahr angeben und den rest macht die Funktion. Hoffe dir ist es klar was ich meine?
VG
Michael
AW: Hilfe in VBA
08.05.2012 20:06:46
Rudi
Hallo, 
Function Steigung2(intYear As Integer, strSheet As String)
Dim objX As Object, objY As Object
Dim arrX, arrY, lngX As Long
With Sheets(strSheet)
arrX = .Range(.Cells(8, 1), .Cells(8, 1).End(xlDown))
arrY = .Range(.Cells(8, 5), .Cells(8, 5).End(xlDown))
End With
Set objX = CreateObject("Scripting.Dictionary")
Set objY = CreateObject("Scripting.Dictionary")
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
objX(lngX) = arrX(lngX, 1) * 1
objY(lngX) = arrY(lngX, 1) * 1
End If
Next lngX
Steigung2 = WorksheetFunction.Slope(objY.items, objX.items)
End Function

=Steigung2;2000;"Tabelle1")
Gruß
Rudi
Anzeige
AW: Hilfe in VBA
08.05.2012 20:44:24
Michael
Hallo Rudi,
Du bist genial :). Das ist super. In meinem Test hat es Funktioniert aber wenn ich es auf meine echten Daten loslasse dann erhalte ich in der Spalte #Value. Ich verstehe nicht wieso das nicht klappt?
Danke für deine Hilfe.
VG
Michael
dann schick mal die Echtdaten. owT
08.05.2012 21:32:58
Rudi
AW: dann schick mal die Echtdaten. owT
08.05.2012 21:45:52
Michael
Hallo Rudi,
das File findest du hier:
https://www.herber.de/bbs/user/80080.xlsm
Das Makro ist auch schon eingebaut für die Steigung. Wenn ich auf Summary Blatt die Steigung Berechne von den Daten im Arbeitsblatt Data dann erhalte ich die Fehlermedlung. Kann es sein das er Probleme mit der letzten zeile hat wenn nichts mehr gefüllt ist?
Danke für deine Hilfe :).
VG
Michael
p.s.: Das Forum hier ist Top!!!!
Anzeige
AW: dann schick mal die Echtdaten. owT
08.05.2012 23:13:44
Rudi
Hallo,
ja, das ist das Prob. 
Function Steigung2(intYear As Integer, strSheet As String)
Dim objX As Object, objY As Object
Dim arrX, arrY, lngX As Long
With Sheets(strSheet)
arrX = .Cells(8, 1).Resize(Application.Count(.Range(.Cells(8, 1), .Cells(Rows.Count, 1). _
End(xlUp))))
arrY = .Cells(8, 1).Resize(Application.Count(.Range(.Cells(8, 1), .Cells(Rows.Count, 1). _
End(xlUp)))).Offset(, 4)
End With
Set objX = CreateObject("Scripting.Dictionary")
Set objY = CreateObject("Scripting.Dictionary")
For lngX = LBound(arrX) To UBound(arrX)
If Year(arrX(lngX, 1)) = intYear Then
objX(lngX) = arrX(lngX, 1) * 1
objY(lngX) = arrY(lngX, 1) * 1
End If
Next lngX
Steigung2 = WorksheetFunction.Slope(objY.items, objX.items)
End Function

Gruß
Rudi
Anzeige
AW: dann schick mal die Echtdaten. owT
09.05.2012 09:05:00
Michael
Hi Rudi,
Genial :)! Das löst alle Probleme. Danke nochmals für deine Hilfe!!!
VG
Michael

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige