Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1428to1432
1428to1432
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

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

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

Array an funktion Übergeben/ Rückgabe im Array spe
05.06.2015 13:20:25
Carlo
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

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

AW: Array an funktion Übergeben/ Rückgabe im Array spe
05.06.2015 13:39:27
Sepp
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

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
05.06.2015 15:07:13
Carlo
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)
Was mache ich falsch?

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

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
05.06.2015 15:38:23
Carlo
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.

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
05.06.2015 15:56:15
Sepp
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

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
05.06.2015 17:05:15
Carlo
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

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
06.06.2015 09:50:54
Carlo
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 :/

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
06.06.2015 10:00:12
Sepp
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

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
06.06.2015 10:58:39
Carlo
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

Anzeige
AW: Array an funktion Übergeben/ Rückgabe im Array spe
06.06.2015 11:12:02
Sepp
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

Anzeige
;

Forumthreads zu verwandten Themen

VBA: Range eindimensionell an Funktion übergeben
axel_k

Hi,
ich möchte aus einer Tabelle Werte aus einer Spalte in eine Funktion einlesen: Function bla(daten) End Function
Wenn ich das tue, liegt daten als (n,1)-Matrix zweidimensional vor.
Kann ich daten irgendwie so einlesen, dass ich einen eindimensionalen Vektor (daten(n)) erhalte?...
31.05.2010 12:02:47
Thread-ID: 1159570
7 Beiträge
VBA: Range eindimensionell an Funktion übergeben
axel_k

Hi,
ich möchte aus einer Tabelle Werte aus einer Spalte in eine Funktion einlesen: Function bla(daten) End Function
Wenn ich das tue, liegt daten als (n,1)-Matrix zweidimensional vor.
Kann ich daten irgendwie so einlesen, dass ich einen eindimensionalen Vektor (daten(n)) erhalte?...
31.05.2010 12:02:47
Thread-ID: 1159570
7 Beiträge
Tabellenarray an Tag der Ufrm übergeben
Peter

Hallo Forum,
ich möchte bestimmte Tabellenblätter, die als Array zusammengefasst sind,
einer Variable zuordnen.
Diese Variable soll bei Aufruf der Ufrm durch eine
Schaltfläche der Tag Eigenschaft der Ufrm übergeben werden und entsprechende
Tabellenblätter ein bzw. ausblenden...
06.12.2009 10:29:57
Thread-ID: 1122029
3 Beiträge
Arraylist-Methode insert() funktioniert nicht
Jörg

Hallo,
was ist am folgenden Code falsch? Ich möchte an zweiter Stelle ein Item mit dem Wert 1 einfügen.
Private Sub test() Dim x As Object Set x = Nothing Set x = CreateObject("System.Collections.ArrayList") x.add 5 x.add 2 x.add 10 x.insert (1,"1") End Sub
Bei der letzten Zeile...
14.02.2010 23:22:13
Thread-ID: 1138543
6 Beiträge
Array an ParmaArray übergeben
Schattenkirchner

Hallo Spezialisten,
ich habe eine Prozedur mit einem ParamArray: Sub TEST (ParamArray Number()) End Sub Der Aufruf
TEST 1, 6, 9, 55, 1000
funktioniert einwandfrei, sofern sich die Anzahl der Numbers in grenzen hält. Wenn ich aber ca. 250 Argumente eintippen muss, wirds schon müssi...
30.05.2010 18:01:45
Thread-ID: 1159471
7 Beiträge
VBA: Range eindimensionell an Funktion übergeben
axel_k

Hi,
ich möchte aus einer Tabelle Werte aus einer Spalte in eine Funktion einlesen: Function bla(daten) End Function
Wenn ich das tue, liegt daten als (n,1)-Matrix zweidimensional vor.
Kann ich daten irgendwie so einlesen, dass ich einen eindimensionalen Vektor (daten(n)) erhalte?...
31.05.2010 12:02:47
Thread-ID: 1159570
7 Beiträge
Tabelle in Funktion übergeben
Dirk

Hallo zusammen!
Frage ist folgendes möglich?
Auf einem Tabellenblatt Tabelle1 befinden sich Images als control
in einer Funktion
function imageoption(ctl as string, wks as Worksheet)
wks(ctl).picture = load picture (blabla)
End Function
Ein Click ereignis soll die W...
30.10.2010 16:14:42
Thread-ID: 1184523
3 Beiträge
Anzeige
Daten aus einer Funktion in Array
Guybrush

Hallo!
Folgendes Problem:
Ich gebe in einer Funktion (Variant) ein Array in ein Worksheet aus.
Im Worksheet ist der Bereich mit SHIFT+CTRL+ENTER markiert.
Die Daten aus der Funktion sind teilweise Datum, Zeit und Zahlen:
z.B.: ab A1:
13.05.2012 00:06:03 140 2
16.05.2...
22.08.2012 19:22:43
Thread-ID: 1276090
5 Beiträge
Data Strucute an Funktion übergeben
Benni

Hallo,
ich habe ein kleines Problem bei der Übergabe von Daten Strukturen an eine Funktion, folgender Aufbau liegt vor:
Ich möchte in der unten S ub "berechnen" die Datenstrukur werte2 übergeben, allerdings sollen in dieser Datenstruktur auch die Werte von der Struktur werte1 enthalten...
28.12.2012 14:50:44
Thread-ID: 1292251
5 Beiträge
Array in Funktion
Andreasser

Guten Morgen allerseits
ich mühe mich jetzt schon seit Stunden mit dem Versuch ab eine einfache Funktion zu schreiben, und zwar habe ich Probleme beim ersten Punkt des Codes. Ich möchte der Funktion noten(bereich) den Bereich übergeben und es sollen alle im Bereich enthaltenen Werte in ein...
29.03.2013 09:05:58
Thread-ID: 1306441
9 Beiträge
3dimensionales Array aus Funktion an Sub übergeben
Sam

Hallo,
ich erzeuge in einer Funktion ein zweidimensionales Array, dieses array bekomme ich jedoch nich an eine Sub, um es dann im Blatt auszugeben.
Wie muss ich hier vorgehen?
18.07.2013 08:43:24
Thread-ID: 1323004
4 Beiträge
Anzeige
Array in Variable schreiben funktioniert nicht
verslaan

Hallo zusammen
Ich habe folgendes Problem:
Ich kopiere mit einem Spezialfilter aus einer Tabelle gewisse Daten in eine zweite Tabelle, für die Daten aus der Filtermatrix muss ich die eine Suche ausführen um die richtige Spalte zu bekommen was auch funktioniert, jedoch kann ich nach Absc...
16.09.2013 13:14:38
Thread-ID: 1330991
8 Beiträge
Anzeige

Beliebteste Forumthreads (12 Monate)

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