AW: Datensätze mit Kriterien ausdünnen
17.05.2018 11:36:00
fcs
Hallo Ianala,
ich hab jetzt mal ein Makro erstellt, das deine Randbedingungen erfüllen sollte.
Gruß
Franz
Sub Daten_Aufbereiten()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim rngDaten As Range
Dim arrDaten, arrErgebnis()
Dim varMaxm_z, varRT_min, varDS
Dim Zeile As Long, Zeile_L As Long
Dim Spalte_Q As Long, Spalte As Long
Set wksQuelle = ActiveWorkbook.Worksheets(1) 'Sheet1
Set wksZiel = ActiveWorkbook.Worksheets(2) 'Tabelle1
With wksQuelle
'Datensätze in Quell-Blatt abarbeiten - ab Spalte B in 6er-Schritten
For Spalte_Q = 2 To .Cells(2, .Columns.Count).End(xlToLeft).Column Step 6
varDS = .Cells(1, Spalte_Q).Value 'Bezeichnung des Datensatzes merken
'Datenzeilen des Datensates sortieren und in Daten-Array einlesen
Zeile_L = .Cells(.Rows.Count, Spalte_Q).End(xlUp).Row
Set rngDaten = .Range(.Cells(2, Spalte_Q), .Cells(Zeile_L, Spalte_Q + 4))
With rngDaten
'sortieren nach "RT [min]" und "Max. m/z"
.Sort Key1:=.Range("B1"), order1:=xlAscending, key2:=.Range("E1"), _
Order2:=xlAscending, Header:=xlYes
'sortierte Daten inkl. Spaltentitel in Array einlesen
arrDaten = .Value2
'sortieren nach "#" - ursprüngliche Sortierung wieder herstellen
.Sort Key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
End With
'im Daten-Array doppelte Datenzeilen markieren
varRT_min = "": varMaxm_z = "": Zeile_L = 1
For Zeile = LBound(arrDaten, 1) + 1 To UBound(arrDaten, 1)
'Prüfen, ob Werte in Spalte "RT [min]" sich ändert
If varRT_min arrDaten(Zeile, 2) Then
'Werte merken von "RT [min]" und "Max. m/z" - Zeile nicht als doppelt markieren
varRT_min = arrDaten(Zeile, 2)
varMaxm_z = arrDaten(Zeile, 5)
Zeile_L = Zeile_L + 1
Else
'Prüfen, ob Wert in "Max. m/z" innerhalb der Toleranz zum gemerkten Wert
If arrDaten(Zeile, 5) - varMaxm_z "D" Then
Zeile_L = Zeile_L + 1
For Spalte = LBound(arrDaten, 2) To UBound(arrDaten, 2)
arrErgebnis(Zeile_L, Spalte) = arrDaten(Zeile, Spalte)
Next
End If
Next
'Ergebnis-Daten im Zielblatt eintragen
With wksZiel
'Datensatz-Beschreibung eintragen in Zeile 1
.Cells(1, Spalte_Q).Value = varDS
'nicht doppelte Daten in Zielblatt eintragen
.Cells(2, Spalte_Q).Resize(Zeile_L, 5) = arrErgebnis
'Zeilen des Datensatzen nach "#" sortieren
Zeile_L = .Cells(.Rows.Count, Spalte_Q).End(xlUp).Row
Set rngDaten = .Range(.Cells(2, Spalte_Q), .Cells(Zeile_L, Spalte_Q + 4))
With rngDaten
'sortieren nach "#"
.Sort Key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
End With
End With
Erase arrDaten, arrErgebnis 'Daten-Arrays zuücksetzen/leeren
Next Spalte_Q
End With
wksZiel.Activate
End Sub