Sub Here()
    Dim TWb As Workbook
    Dim WWSh As Worksheet
    Dim TDay As Date
    Dim TRow As Long
    Set TWb = ThisWorkbook
    Set WWSh = TWb.Worksheets("Foglio1")
    WWSh.Range("Z1").Formula = "=TODAY()"
    WWSh.Range("Z1").NumberFormat = "yyyy-mm-dd"
    TDay = WWSh.Range("Z1").Value
    TRow = 3
    Do
        If Not (WWSh.Cells(TRow, 12).Value >= TDay) Then 'se la data non va bene
            WWSh.Cells(TRow, 12).Clear
            Call There(TRow, TDay, 0)
        End If
        TRow = TRow + 1
    Loop While WWSh.Cells(TRow, 2) <> ""
End Sub

Sub There(TRow As Long, TDay As Date, DCol As Long)
    Dim TWb As Workbook
    Dim WWSh As Worksheet
    Dim RWSh As Worksheet
    Set TWb = ThisWorkbook
    Set WWSh = TWb.Worksheets("Foglio1")
    Set RWSh = TWb.Worksheets("Foglio2")
    Dim Value As Variant
    Dim lRow As Long
    Dim WCol As Long
    Dim Rng As Range
    Value = WWSh.Cells(TRow, 2).Value
    WCol = DCol
    If DCol = 0 Then
        Dim ACol As Long
        ACol = RWSh.UsedRange.Columns.Count
        For i = 1 To ACol
            If (RWSh.Cells(1, i).Value = Value) Then
                WCol = i
                Exit For
            End If
        Next
        If WCol = 0 Then
            GoTo Nav
        End If
    End If
    With RWSh
        lRow = .Cells(.Rows.Count, Col_Letter(WCol)).End(xlUp).Row
    End With
    
    RWSh.Sort.SortFields.Clear
    RWSh.Sort.SortFields.Add Key:=r, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'ordina le date del codice
    With RWSh.Sort
        .SetRange RWSh.UsedRange
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Dim ARow As Long
    ARow = Rng.Count
    If ARow = 1 Then
        MsgBox ("Data non disponibile")
        Exit Sub
    End If
    For i = 2 To ARow
        If (RWSh.Cells(i, DCol).Value >= TDay) Then
            WWSh.Cells(TRow, 12).Value = RWSh.Cells(i, DCol).Value
            Exit For
        End If
    Next
    If DCol = 0 Then
        If Not (WWSh.Cells(TRow, 12).Value >= TDay) Then
             Call Nav(Value, TDay, WCol, TRow)
        End If
    End If
Exit Sub

Nav:
    Call Nav(Value, TDay, WCol + 1, TRow)
End Sub

Sub Nav(Value As Variant, TDay As Date, Col As Long, TRow As Long)
    Dim NWb As Workbook
    Dim TWb As Workbook
    Dim NWs As Worksheet
    Dim RWSh As Worksheet
    Dim NRng As Range
    Dim NRow As Long
    Dim DDay As Collection
    EndF = "storico.xlsx"
    Set NWb = Workbooks.Open(EndF)
    Set NWs = NWb.Worksheets("ODL")
    Set TWb = ThisWorkbook
    Set RWSh = TWb.Worksheets("Foglio2")
    With NWs
        NRow = .Cells(.Rows.Count, "O").End(xlUp).Row
    End With
    'NRng = NWs.Range("O1:O" & NRow)
    NWs.Sort.SortFields.Clear
    NWs.Sort.SortFields.Add Key:=NWs.Range("O1:O" & NRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With NWs.Sort
        .SetRange NWs.UsedRange
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    NWs.UsedRange.AutoFilter
    NWs.UsedRange.AutoFilter Field:=15, Criteria1:=Value
    Set DDay = New Collection
    For i = 2 To NRow 'sta prendendo tutte le date!!!!
        If (NWs.Range("T" & i).Value >= TDay) Then
            DDay.Add NWs.Range("T" & i).Value
        End If
        If (NWs.Range("U" & i).Value >= TDay) Then
            DDay.Add NWs.Range("U" & i).Value
        End If
        If (NWs.Range("V" & i).Value >= TDay) Then
            DDay.Add NWs.Range("V" & i).Value
        End If
    Next
    If Not DDay.Count > 1 Then
        If MsgBox(Value, vbOKOnly, "il codice non fornisce date attive") = vbOK Then
            Exit Sub
        End If
    End If
    For i = 1 To DDay.Count
        RWSh.Cells(i + 1, Col).Value = DDay.Item(i)
    Next
    Set DDay = Nothing
    NWs.UsedRange.AutoFilter
    NWs.Sort.SortFields.Clear
    Set NWs = Nothing
    NWb.Close False
    Set NWb = Nothing
    Call There(TRow, TDay, Col)
End Sub