Array an funktion Übergeben/ Rückgabe im Array spe

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Array an funktion Übergeben/ Rückgabe im Array spe
von: Carlo
Geschrieben am: 05.06.2015 13:20:25

Hallo Liebe Fans!
Ich würde gerne Messerwerte mittels Gaus Methode nach kleinsten Fehlerquadraten einem polynom 9ten grades Annähern. Hierzu habe ich Folgende Funktion gefunden:

Function GaussRegression(x, y, n As Integer)
ReDim f(0 To n, 0 To n) As Double
ReDim t(1 To n + 1) 'As Double
Dim a, p As Integer, i As Integer, j As Integer, k As Integer, s As Integer
On Error Resume Next
' Range expected starts at s = 1
p = x.Count: s = 1
If Err.Number Then
' VarArray starts at s = 0
    Err.Clear:
    p = UBound(x)
    s = 0
End If
' Calculate Gausssum
For i = 0 To n
    For j = 0 To n
        For k = s To p
            f(i, j) = f(i, j) + x(k) ^ (n - j) * x(k) ^ (n - i)
        Next
    Next
    For k = s To p
        t(i + 1) = t(i + 1) + y(k) * x(k) ^ (n - i)
    Next
Next
End Function

Die Übergabewerte sind zum einen ein Array mit Zeit Variablen (Integer) und ein Array mit Messwerten (Double) und der Polynomgrad (9). Wie kann ich diese Werte Übergeben und die berechneten Variablen (aus dieser Funktion) in einem neuen Array schreiben? Im Orginal Sheet ist die Ausgabe in einem Arbeitsblatt-Array (1,10).
Grusz Carlo

Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Carlo
Geschrieben am: 05.06.2015 13:24:02
Copy Paste hasst mich: Am Ende zwischen Next und End funktion steht noch:
a = WorksheetFunction.MInverse(f)
GaussRegression = WorksheetFunction.MMult(t, a)

Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Sepp
Geschrieben am: 05.06.2015 13:39:27
Hallo Crlo,
z. B. so.

Sub test()
  Dim ret As Variant
  Dim x As Variant, y As Variant
  
  x = Array(100, 101, 102, 103, 104, 105, 106, 107, 108, 109)
  y = Array(1, 2, 1.8, 2.1, 1.4, 2, 1.8, 2.2, 2, 1.6)
  
  ret = GaussRegression(x, y, 9)
End Sub


Gruß Sepp


Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Carlo
Geschrieben am: 05.06.2015 15:07:13
Vielen Dank für die schnelle Antwort. Irgendwie funktioniert es nicht. Ich habe es so eingebaut:

Sub Main()
   Dim iRow As Integer  'Variablendeklaration für Zählschleife
   Dim h As Integer 'Hilfsvariable für das Array
   Dim x, y As Variant
   Dim Gaus As Variant
   iRow = 2 'Startwert setzen
   h = 0    'Startwert setzen
    
   While Not IsEmpty(Cells(iRow, 2))    'Schleifenbeginn
      
        If Cells(iRow, 2) > 0.1 Then 'Bedingung für alle Peakwerte
        ReDim x(h)         'h Elemente reservieren
        ReDim y(h)
        x(h) = Cells(iRow, 2) 'Befüllen des Werte Arrays
        y(h) = Cells(iRow, 1)  ' Befüllen des Zeit Arrays
        h = h + 1   'nächster Peakarray-Eintrag
        End If   'Peakende
            If Cells(iRow, 2) > 0.1 And Cells(iRow + 1, 2) < 0.1 Then
            
            Gaus = GaussReg.GaussRegression(x, y, 9)
                
            End If   ' Peakende
    iRow = iRow + 1
   Wend
   
End Sub
Was mache ich falsch?

Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Sepp
Geschrieben am: 05.06.2015 15:14:16
Hallo Carlo,
Was mache ich falsch? Dazu müsste man schon genauer wissen, was du erreichen willst, bzw. wie deine Daten aussehen.

Gruß Sepp


Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Carlo
Geschrieben am: 05.06.2015 15:38:23
Meine Daten:
A B
0 0,003065
1 1,113314
2 0,673064
3 0,459486
4 0,299186
5 0,18557
6 0,104104
7 0,059482
8 0,037055
9 0,025154
10 0,019394
11 0,015801
12 0,013497
13 0,011742
14 0,003065
15 1,113314
16 0,673064
17 0,459486
18 0,299186
19 0,18557
20 0,104104
21 0,059482
22 0,037055
23 0,025154
24 0,019394
25 0,015801
26 0,013497
27 0,011742
Ich möchte, dass alle Werte bei denen B größer 0.1 sind in einem Array Speichern (in getrennten Arrays ; Also in diesem Fall 2 Peaks). Zusätzlich soll die dazugehörige Zeit (A) in ein Array gespeichert werden. Diese jeweils zwei Arrays sollen an die Funktion GaussReg.GaussRegression(x, y, 9) weitergegeben werden und diese gibt Parameter für eine polynomische Gleichung zurück. Jeder Peak wird mit einer eigenen Gleichung regressiv angenähert.

Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Sepp
Geschrieben am: 05.06.2015 15:56:15
Hallo Carlo,

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub test()
  Dim varGauss() As Variant, varTmp As Variant
  Dim varX() As Variant, varY() As Variant
  Dim lngXY As Long, lngI As Long
  Dim lngLast As Long, lngRow As Long
  
  With Sheets("Tabelle1") 'Tabellenname anpassen!
    lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
    
    For lngRow = 2 To lngLast
      If .Cells(lngRow, 2) > 0.1 And (.Cells(lngRow + 1, 2) > 0.1 Or lngRow = lngLast) Then
        Redim Preserve varX(lngXY)
        Redim Preserve varY(lngXY)
        varX(lngXY) = .Cells(lngRow, 1)
        varY(lngXY) = .Cells(lngRow, 2)
        lngXY = lngXY + 1
      Else
        If lngXY > 0 Then
          varTmp = GaussRegression(varX, varY, 9)
          Redim Preserve varGauss(lngI)
          varGauss(lngI) = varTmp
          lngI = lngI + 1
          Erase varX
          Erase varY
          lngXY = 0
        End If
      End If
    Next
    
  End With
  ' und was passiert jetzt mit varGauss?
End Sub



Function GaussRegression(x, y, n As Integer)
  Redim f(0 To n, 0 To n) As Double
  Redim t(1 To n + 1) 'As Double
  Dim a, p As Integer, i As Integer, j As Integer, k As Integer, s As Integer
  On Error Resume Next
  ' Range expected starts at s = 1
  p = x.Count: s = 1
  If Err.Number Then
    ' VarArray starts at s = 0
    Err.Clear:
    p = UBound(x)
    s = 0
  End If
  ' Calculate Gausssum
  For i = 0 To n
    For j = 0 To n
      For k = s To p
        f(i, j) = f(i, j) + x(k) ^ (n - j) * x(k) ^ (n - i)
      Next
    Next
    For k = s To p
      t(i + 1) = t(i + 1) + y(k) * x(k) ^ (n - i)
    Next
  Next
  
  a = WorksheetFunction.MInverse(f)
  GaussRegression = WorksheetFunction.MMult(t, a)
End Function


Was soll nun weiter geschehen?
Gruß Sepp


Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Carlo
Geschrieben am: 05.06.2015 17:05:15
Vielen Dank Sepp!
Langfristig ist das Ziel für jeden Peak eine eigene Tabelle mit Peakwerten(varx()/vary()/vary,max), Koefizienten der Regression(varGauss)und der Peak-Fläche (Integration der Regression) anzulegen. (Optimal wäre noch ein Graph der die Regression und die Messwerte zusammen abbildet *träum*).Ich werde mich nochmal ein wenig dransetzten! Danke nochmal!
Grusz Carlo

Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Carlo
Geschrieben am: 06.06.2015 09:50:54
Hallo erneut!
Eine Frage hätte ich noch:
Ich verstehe das Füllen von varGauss nicht so richtig, da varTmp(rückgabe Regression) eigentlich schon das richtige Array seien müsste. Jedenfalls kriege ich keine Wertausgabe für varGauss bzw. weiß nicht wie ich die berechnung überprüfen kann. Msgbox und degubprint wollen irgendwie nicht :/

Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Sepp
Geschrieben am: 06.06.2015 10:00:12
Hallo Carlo,
du wolltest doch mehrere Ausgaben für mehrere Peaks! und genau diesen sind, wiederum als Arrays in varGauss enthalten. Daher kam ja auch meine Frage: "Was soll nun weiter geschehen".
Wie und wo du die Ausgaben weiterverarbeiten willst, kann ich nicht wissen.

Sub test()
  Dim varGauss() As Variant, varTmp As Variant
  Dim varX() As Variant, varY() As Variant
  Dim lngXY As Long, lngI As Long
  Dim lngLast As Long, lngRow As Long
  
  Dim lngN As Long, lngM As Long, strTemp As String
  
  With Sheets("Tabelle1") 'Tabellenname anpassen!
    lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
    
    For lngRow = 2 To lngLast
      If .Cells(lngRow, 2) > 0.1 And (.Cells(lngRow + 1, 2) > 0.1 Or lngRow = lngLast) Then
        Redim Preserve varX(lngXY)
        Redim Preserve varY(lngXY)
        varX(lngXY) = .Cells(lngRow, 1)
        varY(lngXY) = .Cells(lngRow, 2)
        lngXY = lngXY + 1
      Else
        If lngXY > 0 Then
          varTmp = GaussRegression(varX, varY, 9)
          Redim Preserve varGauss(lngI)
          varGauss(lngI) = varTmp
          lngI = lngI + 1
          Erase varX
          Erase varY
          lngXY = 0
        End If
      End If
    Next
    
  End With
  ' und was passiert jetzt mit varGauss?
  
  For lngN = LBound(varGauss) To UBound(varGauss)
    strTemp = ""
    For lngM = LBound(varGauss(lngN)) To UBound(varGauss(lngN))
      strTemp = strTemp & varGauss(lngN)(lngM) & vbLf
    Next
    MsgBox strTemp
  Next
End Sub


Gruß Sepp


Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Carlo
Geschrieben am: 06.06.2015 10:58:39
Vielen Dank nochmal und du hast absolut Recht, ist genau das was ich wollte. Meine Kentnisse haben nur nicht mal zum erstellen einer Ausgabe gereicht :D
Eigentlich möchte ich jede Peakauswertung in einem eigenen Arbeitsblatt dargestellt haben(Peakwerte Peakzeit und varGauss). Werde mich nochmal an nen Freund wenden.
Grusz

Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Sepp
Geschrieben am: 06.06.2015 11:12:02
Hallo Carlo,
Ausgabe auf fortlaufenden Blättern geht z. B. so.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub test()
  Dim varGauss As Variant
  Dim varX() As Variant, varY() As Variant
  Dim lngXY As Long, lngI As Long
  Dim lngLast As Long, lngRow As Long
  Dim objSh As Worksheet, objSrc As Worksheet
  
  Set objSrc = Sheets("Tabelle1") 'Tabellenname anpassen!
  
  With objSrc
    lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
    
    For lngRow = 2 To lngLast
      If .Cells(lngRow, 2) > 0.1 And (.Cells(lngRow + 1, 2) > 0.1 Or lngRow = lngLast) Then
        Redim Preserve varX(lngXY)
        Redim Preserve varY(lngXY)
        varX(lngXY) = .Cells(lngRow, 1)
        varY(lngXY) = .Cells(lngRow, 2)
        lngXY = lngXY + 1
      Else
        If lngXY > 0 Then
          varGauss = GaussRegression(varX, varY, 9)
          lngI = lngI + 1
          If Not SheetExist("Peak " & lngI) Then
            Set objSh = ThisWorkbook.Worksheets.Add(after:=IIf(lngI = 1, objSrc, objSh))
            objSh.Name = "Peak " & lngI
          Else
            Set objSh = Sheets("Peak " & lngI)
            objSh.Cells.Clear
          End If
          objSh.Cells(1, 1).Resize(UBound(varX) + 1, 1) = Application.Transpose(varX)
          objSh.Cells(1, 2).Resize(UBound(varY) + 1, 1) = Application.Transpose(varY)
          objSh.Cells(1, 4).Resize(UBound(varGauss), 1) = Application.Transpose(varGauss)
          Erase varX
          Erase varY
          lngXY = 0
        End If
      End If
    Next
    
  End With
  
End Sub




Function GaussRegression(x, y, n As Integer)
  Redim f(0 To n, 0 To n) As Double
  Redim t(1 To n + 1) 'As Double
  Dim a, p As Integer, i As Integer, j As Integer, k As Integer, s As Integer
  On Error Resume Next
  ' Range expected starts at s = 1
  p = x.Count: s = 1
  If Err.Number Then
    ' VarArray starts at s = 0
    Err.Clear:
    p = UBound(x)
    s = 0
  End If
  ' Calculate Gausssum
  For i = 0 To n
    For j = 0 To n
      For k = s To p
        f(i, j) = f(i, j) + x(k) ^ (n - j) * x(k) ^ (n - i)
      Next
    Next
    For k = s To p
      t(i + 1) = t(i + 1) + y(k) * x(k) ^ (n - i)
    Next
  Next
  
  a = WorksheetFunction.MInverse(f)
  GaussRegression = WorksheetFunction.MMult(t, a)
End Function


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function


Gruß Sepp


Bild

Betrifft: AW: Array an funktion Übergeben/ Rückgabe im Array spe
von: Sepp
Geschrieben am: 06.06.2015 11:22:55
Hallo nochmal,
hier ein besseres Beispiel.
https://www.herber.de/bbs/user/98064.xlsm

Gruß Sepp


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Array an funktion Übergeben/ Rückgabe im Array spe"