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

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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)

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.

' ********************************************************************** ' 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

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

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

Beliebteste Forumthreads (12 Monate)

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

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

53 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

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

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

53 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread