|
Hallo Office-Gurus,
Für eine optische Messung habe ich Spekraltabellen in .txt files mit Wellenlängen(X) und Intensitäten(Y) aufgenommen.
Ich habe bereits ein Makro, dass für jede .txt Tabelle in einem Ordner das Y-Maximum in einem definierten X-Bereich ermittelt und beide Werte samt Dateinamen in einer Tabelle ausgibt.
Dieses Makro ist angehängt.
Ich möchte es so modifizieren, dass es im selben definierten X-Bereich alle markanten "Peaks" findet und ebenso ausgibt.
ein "Peak" ist für mich ein Wert Y , dessen vorgehenden und nachfolgen 50 Werte allesamt kleiner sind als Y. (hier gibt es sicherlich elegantere Varianten, ich vermute aber diese Definition reicht aus.)
Ausgegeben möchte ich nun eine Tabelle mit Dateinamen und allen Peaks mit seinen X- und Y-Werten in dieser Datei, dann die nächste usw.
Ich hoffe ich irre mich nciht, aber die dafür relevanten Zeilen im Code müssten Zeile 54-66 sein.
kann mir bitte jemand helfen?
Viele Grüße und besten Dank,
Rolfor
Makro:
********************************************************************
Alle Textdateien in einem Ordner (Auswahlfenster) einlesen,
den Maximalwert (Spalte B) zwischen best. Zeilen s.u. auslesen
und mit zugehörigem Spalte-A-Wert und Dateiname in tabelle ausgeben.
********************************************************************
'Makro in einem allgemeinen Modul
Sub prcGet_Max_from_TXT()
Dim wksZiel As Worksheet
Dim Zeile_Z As Long, Zeile As Long
Dim varA, dblMax As Double
Dim wkbTxt As Workbook, wksTxt As Worksheet
Dim varOrdner As Variant, varDatei
Dim varData As Variant
Set wksZiel = ActiveSheet
With wksZiel
'letteZeile in Spalte A mit Inhalt
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'Ordner auswählen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte den Ordner mit den Text-Dateien auswählen"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
Application.ScreenUpdating = False
'txt-Dateien suchen
varDatei = Dir(varOrdner & "\*.txt")
Do Until varDatei = ""
'Textdatei öffnen - 1000er- und Dezimal-Trennzeichen anpassen, Local auf False _
setzen wenn Daten nicht mit den lokalen Einstellungen der Systemsteuerung übereinstimmen.
Application.Workbooks.OpenText Filename:=varOrdner & "\" & varDatei, Origin:=xlWindows, _
Startrow:=1, DataType:=xlDelimited, Tab:=False, Semicolon:=False, Comma:=False, _
Space:=True, Other:=False, ThousandsSeparator:=",", DecimalSeparator:=".", _
Local:=True
Set wkbTxt = ActiveWorkbook
Set wksTxt = wkbTxt.Sheets(1)
'Daten in SpaltenA und B in eine Daten-Array schreiben - Auswertung geht dann schneler.
With wksTxt
varData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
End With
'Werte für Spalte A und B zurücksetzen
varA = "no Data"
dblMax = -99999
If UBound(varData, 1) >= 428 Then
varA = varData(428, 1)
dblMax = varData(428, 2)
'Hier Grenzen einsetzen! (428=380,116; 1131=700,284; 1198=730,088; 1221=740,734; 1243=750,036; 1266=760,21; 1289=770,369; 1313=780,953; 1357=800,316)
For Zeile = 428 To 1313
If IsNumeric(varData(Zeile, 2)) Then
If varData(Zeile, 2) > dblMax Then
varA = varData(Zeile, 1)
dblMax = varData(Zeile, 2)
End If
End If
Next
End If
'text-Datei ohne speichern wieder schliesen
wkbTxt.Close savechanges:=False
'daten-Array löschen
Erase varData
'gefundenen Werte in Zieltabelle eintragen
With wksZiel
Zeile_Z = Zeile_Z + 1
.Cells(Zeile_Z, 1) = varA
.Cells(Zeile_Z, 2) = dblMax
.Cells(Zeile_Z, 3) = varDatei
End With
'nächste datei suchen
varDatei = Dir
Loop
Beenden:
Application.ScreenUpdating = True
End Sub
|