Hallo ! Kann grad nicht testen. Habe aber mal schnell geschaut und recherchiert. Probiere es mal so wie unten. In nem anderen Forum stand, dass es gehen sollte, wenn du den Wert als String formatierst. Ist unten geschehen aber ungetestet - weis also nicht, ob es klappt. Komme erst später zum Probieren. VG
Public DataReturn, DataExposure, PFExposure As Worksheet
Sub SortExposure()
Set DataReturn = Worksheets("Monatl. Aktienrenditen(1)")
Set DataExposure = Worksheets("monatl. Ölexposure")
Set PFExposure = Worksheets("<- Öl Portfolio")
Dim letzte As Long 'nimmt die letzte Zeile zum eintragen auf
Dim x As Integer
Dim Elast As Variant 'Kriterium
Dim Elast2 As Variant
Dim i As Integer
Dim Exposnum As Integer
For i = 1 To 11 ' Schleife für das Kriterium
Elast = PFExposure.Cells(3, i).Value ' Nehme den Wert für das Kriterium von auf
Elast2 = PFExposure.Cells(3, i + 1).Value ' Nehme den Wert für das Kriterium bis auf
' erhöht um 3 bei jedem x dadurch ist die Schrittweite 3 gewahrt
Exposnum = 3 * i - 2 'ist immer die Zeile zum Einfügen,keine Schleife, sonst wird dein Kriterum 1 auch bei Kriterum 2 eingetragen
For x = 2 To 180 Step 1 ' Schleife für die einzelnen Monate
DataExposure.Range("A:FY").AutoFilter Field:=x, Criteria1:=">" & Str(Elast) & "", Operator:=xlAnd, Criteria2:="<=" & Str(Elast2) & ""
'prüfen, ob Auotfiler was ergibt
If DataExposure.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
'letzten Eintrag suchen, in erste Spalte des 3er Packs, da dort das Datum drüber steht
letzte = PFExposure.Cells(Rows.Count, Exposnum).End(xlUp).Row 'ich habe mal in Spalte 1 gesucht, wegen der Überschrift des Monates
'Datum einfügen
PFExposure.Cells(letzte + 1, Exposnum) = DataExposure.Cells(1, x)
'Namen kopieren
DataExposure.Range("A2:A" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Copy
PFExposure.Cells(letzte + 2, Exposnum).PasteSpecial
'Daten kopieren
DataExposure.Range(Cells(2, x), Cells(ActiveSheet.UsedRange.Rows.Count, x)).SpecialCells(xlCellTypeVisible).Copy
PFExposure.Cells(letzte + 2, Exposnum + 2).PasteSpecial
DataExposure.ShowAllData
End If
Next x
Next i
End Sub
|