NAbend (schon zu spät für Moin)! Also dann probier mal den Code. Bei den elast musst du mal noch schauen, ob das so past. Die Konvertierung zum String ist glaube ich schon drin aber der beim Datentyp von elast bin ich mir nicht sicher. Also in der Schleife mit x wird am Ende nach dem EIntragungen jetzt eine SChleife durch alle Eintragungen gestartet und dann der Wert aus den Renditen übernommen. Sieht vllt. ein wenig kryptisch aus aber eigentlich suche ich nur den Namen in REnditen und wähle dann die Zeile des Monates. Hätte man wohl auch in mehrer Schritte aufteilen können aber so war's kompakt.

Wie immer, bitte mal schauen, ob es passt. Und keine Angst wegen dem nerven. Wenn dem so wäre, würde ich ja hier nicht schreiben und (versuchen) Probleme lösen. :-) Also schönen Abend noch.  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 Long
     
Dim Elast As Variant 'Kriterium
Dim Elast2 As Variant
    
Dim i As Long
Dim a As Long
     
Dim Exposnum As Long
     
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
                
                a = 1
                While PFExposure.Cells(letzte + 1 + a, Exposnum) <> ""
                    If Application.WorksheetFunction.CountIf(DataReturn.Columns(1), PFExposure.Cells(letzte + 1 + a, Exposnum)) > 0 Then
                        PFExposure.Cells(letzte + 1 + a, Exposnum + 1) = DataReturn.Cells(DataReturn.Columns(1).Find(PFExposure.Cells(letzte + 1 + a, Exposnum)).Row, x)
                    End If
                    a = a + 1
                Wend
     
                'DataExposure.ShowAllData
                'filter nochmal aufrufen löscht ihn wieder
               
            End If
              
            DataExposure.Range("A:FY").AutoFilter
        Next x
           
        Next i
           
     
End Sub