Prioritize rows based on info in cells

[Olavfinnerud]

Hi, I have a spread sheet that is used for storing potential building projects See ( image). I want to get a VBA code that prioritize the projects based on information in the D column, F column and P column.

1. If D contains "Offentlig", F contains either "Skolebygg", "Helsebygg", "Offentlig formålsbygg", "Offentlig næring", "Barnehage" or "Kultur" and P contains a date that is less than one year ahead 1 should appear in the B column.
2. If D contains "Privat", F contains "Industri" or "Næring" and P contains a date that is less than one year ahead 2 should appear in the B column.

I tried to do this for several ours but i am unsuccsessful. It would be much appreciated if someone could help me out. Thank you in advance!

The code i have now is:

Sub FindAndMarkCombinationsWithDateCheck()
    Dim findRng As Range
    Dim findStr1 As String
    Dim findStr2 As String
    Dim foundCell As Range
    Dim firstMatch As String
    Dim foundInRow As Long
    Dim ws As Worksheet
    Dim lastRow As Long

    Set ws = ThisWorkbook.Sheets("sheet1")
    
    Set findRng = ws.Range("D:D")
    findStr1 = "Offentlig"
    findStr2 = "Skolebygg"

    Dim checkValues As Variant
    checkValues = Array("Helsebygg", "Offentlig formålsbygg", "Offentlig næring", "Barnehage", "Kultur")

    Set foundCell = findRng.Find(what:=findStr1, LookIn:=xlFormulas, MatchCase:=False, lookat:=xlWhole)

    Do While Not foundCell Is Nothing
        firstMatch = foundCell.Address
        foundInRow = foundCell.Row
        
        If ws.Cells(foundInRow, "F").Value = findStr2 Then
          
            Dim dateInColumnP As Date
            dateInColumnP = ws.Cells(foundInRow, "P").Value
            If DateDiff("yyyy", Date, dateInColumnP) < 1 Then
              
                Dim cellValue As String
                cellValue = ws.Cells(foundInRow, "D").Value
                If IsInArray(cellValue, checkValues) Then
                  
                    ws.Cells(foundInRow, "B").Value = 3
                End If
            End If
        End If

      
        Set foundCell = findRng.FindNext(foundCell)

        
        If foundCell.Address = firstMatch Then Exit Do
    Loop
    

    If ws.Cells(1, "B").Value = "" Then
        MsgBox "Combination not found"
    End If
End Sub

Function IsInArray(val As String, arr As Variant) As Boolean
    Dim item As Variant
    For Each item In arr
        If val = item Then
            IsInArray = True
            Exit Function
        End If
    Next item
    IsInArray = False
End Function

 

[CesarF]

I suggest you to add a new hidden column with all conditions you've mentioned, generating a numeric result regarding the order you need, and then sort your range based in that column.