Hüllkurve - Gefundene Werte säubern
10.06.2018 10:49:55
Norman
mein Programm soll eine Hüllkurve bilden und durchsucht dafür zunächst
eine Matrix mit Wegwerten. Diesen ordnet es dann Kraftwerte aus einer zweiten Matrix zu.
Dabei sollen aber pro Graph, für einen Wegpunkt, lediglich Min und Max der Kraftwerte gespeichert werden.
Auch wenn für diesen Wegpunkt mehr Kraftwerte gefunden wurden.
Hierfür werden zunächst alle gefundenen Kraftwerte zwischengespeichert.
Danach sucht die Teilfunktion diese Werte auf min und max, speichert diese zwischen, löscht alle Werte und schreibt min und max wieder rein.
Teilfunktion:
' *** Mehrfachwerte pro Messreihe abfangen - Teil 2 - START ***
If treffer > 2 Then
' Min & Max Werte der Treffer ermitteln
'Workbooks(zDatei).Worksheets(ThisWorkbook).Sheets (10)
'Workbooks(zDatei).Sheets(10).Select
Workbooks(zDatei).Activate
With Application.WorksheetFunction
' Beispiel: Cells(j, Spaltenzaehler + 2).Value = Application. _
WorksheetFunction.Min(Range(Cells(j, 1), Cells(j, Spaltenzaehler)))
trefferMin = .Min(Range(Cells(j, trefferspalte1), Cells(j, (Spaltenzaehler + 1)) _
))
trefferMax = .Max(Range(Cells(j, trefferspalte1), Cells(j, (Spaltenzaehler + 1)) _
))
' alte Werte löschen
Range(Cells(j, trefferspalte1), Cells(j, Spaltenzaehler + 1)).ClearContents
' Min und Max Werte einfügen
Cells(j, trefferspalte1) = trefferMin
Cells(j, trefferspalte1 + 1) = trefferMax
End With
End If
' *** Mehrfachwerte pro Messreihe abfangen - Teil 2 - ENDE ***
Normal dürften pro Graph nicht mehr als 2 Kraftwerte vorhanden sein.
Aus mir nicht nachvollziehbaren Gründen erscheinen aber ab und zu 3.
Woran könnte das liegen?
Zur besseren Veranschaulichung:
Spalte 1 (blau) = Wegwerte
Spalte 2 & 3 (hellgrün) = Kraftwerte von Messkurve 1
Spalte 4 & 5 (grün) = Kraftwerte von Messkurve 2
Spalte 6 (rot) = Werte die nicht existieren dürften
Das Ganze passiert bei 2*2*19000 genau 6 mal.
Wie hab ich da ne Chance den Fehler zu finden?
Irgendwelche Tipps
Gesamtcode:
Sub Datei_import()
' ###### Varibalen definieren & initialisieren - START ######
' --- Variablen für Programmablauf ---
Dim zDatei As String ' Zieldatei
Dim zPfad As String ' Zielpfad mit Datei
Dim zPfadH As String ' Zielpfad ohne Datei
Dim startzeile As Long
startzeile = 5
Dim endzeile As Long
Dim endspalte As Integer
Dim plotanz As Integer
Dim werteanz As Integer
Dim Spaltenzaehler As Integer
Dim treffer As Integer
Dim trefferspalte1 As Integer
Dim trefferMin As Double
Dim trefferMax As Double
Dim TZersterTreffer As Integer
Dim TZletzterTreffer As Integer
Dim Suchfenster As Integer
Dim ersterSuchwert As Integer
Dim letzterSuchwert As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim H1 As Double
' ### Varibalen initialisieren - START ###
Suchfenster = 1000
H1 = 0
' ### Varibalen initialisieren - ENDE ###
Application.ScreenUpdating = False
'=========================================================================================== _
_
' ###### Dateien laden und verknüpfen - START ######
' #### Arbeitsdatei ####
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Datei wählen"
.InitialFileName = "C:\VBA-Test\" '!!! Pfad anpassen zu - ein Ordner ü _
_
ber Zielordner
If .Show = -1 Then
zDateiH = .SelectedItems(1)
End If
End With
UserForm1.Show 0
UserForm1.Repaint
Set fso = CreateObject("Scripting.FileSystemObject")
oname = fso.getfilename(zPfadH)
' aktive Datei "Workbooks wird genau der Datei aus dem gebauten Pfad zugeordnet
Workbooks.Open zDateiH ' Zieldatei
zDatei = ActiveWorkbook.Name
' ###### Dateien laden und verknüpfen - START ######
'=========================================================================================== _
_
' ###### Spalten und Zeilen zählen - START ######
endspalte = Workbooks(zDatei).Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
endzeile = Workbooks(zDatei).Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
plotanz = endspalte - 4
werteanz = endzeile - startzeile
' #### Datenreihen errechnen - Datensätze errechnen
' ###### Spalten und Zeilen zählen - ENDE ######
For i = 1 To 19000
H1 = i
H1 = H1 / 1000
Workbooks(zDatei).Sheets(10).Cells(i, 5).Value = H1
Next
For i = 1 To werteanz ' --> Zählt die eingelesenen Plots
For j = 1 To 19000 ' --> Zählt alle möglichen Wegwerte
treffer = 0
' ################################################################################## _
_
' ########### Erster Durchlauf pro Kurve - START ###########
If j = 1 Then
For k = startzeile To endzeile ' --> Zählt die Messwerte durch
If Workbooks(zDatei).Sheets(7).Cells(k, i) = j / 1000 Then ' ( _
Zeile, Spalte)
Spaltenzaehler = Workbooks(zDatei).Sheets(10).Cells(j, Columns.Count). _
_
End(xlToLeft).Column
Workbooks(zDatei).Sheets(10).Cells(j, Spaltenzaehler + 1) = Workbooks( _
_
zDatei).Sheets(9).Cells(k, i)
' *** Mehrfachwerte pro Messreihe abfangen - Teil 1 - START ***
' --> Mehrfachwerte der Messreihe werden abgefangen und nur Min und _
_
Max Wert gespeichert
treffer = treffer + 1
If treffer = 1 Then
trefferspalte1 = Spaltenzaehler + 1
End If
' *** Mehrfachwerte pro Messreihe abfangen - Teil 1 - ENDE ***
' *** Trefferzeilen notieren - START ***
' --> Zeilenwerte der Treffer werden notiert.
' --> Ab dem zweiten j-Wert werden nicht mehr alle Wegwerte sondern
' --> nur noch ein Bereich um den Treffer geprüft
If treffer = 1 Then
TZersterTreffer = k
End If
If treffer > 1 Then
TZletzterTreffer = k
End If
' *** Trefferzeilen notieren - START ***
End If
Next
' *** Mehrfachwerte pro Messreihe abfangen - Teil 2 - START ***
If treffer > 2 Then
' Min & Max Werte der Treffer ermitteln
'Workbooks(zDatei).Sheets(10).Select
With Application.WorksheetFunction
' Beispiel: Cells(j, Spaltenzaehler + 2).Value = _
_
Application.WorksheetFunction.Min(Range(Cells(j, 1), Cells(j, Spaltenzaehler)))
trefferMin = .Min(Range(Cells(j, trefferspalte1), Cells(j, _
Spaltenzaehler)))
trefferMax = .Max(Range(Cells(j, trefferspalte1), Cells(j, _
Spaltenzaehler)))
' alte Werte löschen
Range(Cells(j, trefferspalte1), Cells(j, Spaltenzaehler)). _
ClearContents
' Min und Max Werte einfügen
Cells(j, trefferspalte1) = trefferMin
Cells(j, trefferspalte1 + 1) = trefferMax
End With
End If
' *** Mehrfachwerte pro Messreihe abfangen - Teil 2 - ENDE ***
End If
' ########### Erster Durchlauf pro Kurve - ENDE ###########
' ################################################################################## _
_
' ########### Voreinstellungen für Schleife Durchlauf2 - START ###########
ersterSuchwert = TZersterTreffer - Suchfenster
letzterSuchwert = TZletzterTreffer + Suchfenster
If j endzeile Then
letzterSuchwert = endzeile
End If
' *** Maximum Ende bei "endzeile" - ENDE ***
' ########### Voreinstellungen für Schleife Durchlauf2 - ENDE ###########
' ########### Ab zweiter Durchlauf pro Kurve - START ###########
If j > 1 Then
' For k = startzeile To endzeile
For k = ersterSuchwert To letzterSuchwert ' --> Zählt die _
Messwerte durch
If Workbooks(zDatei).Sheets(7).Cells(k, i) = j / 1000 Then ' ( _
_
Zeile, Spalte)
Spaltenzaehler = Workbooks(zDatei).Sheets(10).Cells(j, Columns.Count) _
_
.End(xlToLeft).Column
Workbooks(zDatei).Sheets(10).Cells(j, Spaltenzaehler + 1) = _
Workbooks(zDatei).Sheets(9).Cells(k, i)
' *** Mehrfachwerte pro Messreihe abfangen - Teil 1 - START ***
' --> Mehrfachwerte der Messreihe werden abgefangen und nur Min _
_
und Max Wert gespeichert
treffer = treffer + 1
If treffer = 1 Then
trefferspalte1 = Spaltenzaehler + 1
End If
' *** Mehrfachwerte pro Messreihe abfangen - Teil 1 - ENDE ***
' *** Trefferzeilen notieren - START ***
' --> Zeilenwerte der Treffer werden notiert.
' --> Ab dem zweiten j-Wert werden nicht mehr alle Wegwerte _
sondern
' --> nur noch ein Bereich um den Treffer geprüft
If treffer = 1 Then
TZersterTreffer = k
End If
If treffer > 1 Then
If TZletzterTreffer 2 Then
' Min & Max Werte der Treffer ermitteln
'Workbooks(zDatei).Worksheets(ThisWorkbook).Sheets (10)
'Workbooks(zDatei).Sheets(10).Select
Workbooks(zDatei).Activate
With Application.WorksheetFunction
' Beispiel: Cells(j, Spaltenzaehler + 2).Value = _
_
Application.WorksheetFunction.Min(Range(Cells(j, 1), Cells(j, Spaltenzaehler)))
trefferMin = .Min(Range(Cells(j, trefferspalte1), Cells(j, ( _
Spaltenzaehler + 1))))
trefferMax = .Max(Range(Cells(j, trefferspalte1), Cells(j, ( _
Spaltenzaehler + 1))))
' alte Werte löschen
Range(Cells(j, trefferspalte1), Cells(j, Spaltenzaehler + 1)). _
_
ClearContents
' Min und Max Werte einfügen
Cells(j, trefferspalte1) = trefferMin
Cells(j, trefferspalte1 + 1) = trefferMax
End With
End If
' *** Mehrfachwerte pro Messreihe abfangen - Teil 2 - ENDE ***
' *** Spaltenzähler für nächste Messreihe positionieren - START ***
If treffer = 1 Then
Spaltenzaehler = trefferspalte1 + 1
ElseIf treffer > 1 Then
Spaltenzaehler = trefferspalte1 + 2
End If
' *** Spaltenzähler für nächste Messreihe positionieren - ENDE ***
End If
' ########### Ab zweiter Durchlauf pro Kurve - ENDE ###########
' ################################################################################## _
_
Next
Next
Unload UserForm1
Application.ScreenUpdating = True
MsgBox "Datenimport und -aufbereitung fertig!"
End Sub
