Déterminer 1er lundi du mois en semaine paire etc...

Option Explicit
'variables 
Dim Annee As Integer
Dim Mois As Integer
Dim Jour As Integer

'la sub principale :
Sub test()
MsgBox Combientieme("MERCREDI", CDate("12/02/2014"))
End Sub

'Les fonctions : 

Function Combientieme(Jourdelasemaine As String, maDate As Date) As Integer
Dim i, Dates As Object, Cpt As Integer

Mois = Month(maDate)
Annee = Year(maDate)
Set Dates = CreateObject("Scripting.Dictionary")
For i = 1 To DernierJour(Mois, Annee)
    If UCase(Format(i & "/" & Mois & "/" & Annee, "dddd")) = UCase(Jourdelasemaine) Then
        Cpt = Cpt + 1
        Dates(CDate(i & "/" & Mois & "/" & Annee)) = Cpt
    End If
Next i
Combientieme = Dates(maDate)
End Function

Function DernierJour(Mois As Integer, Annee As Integer) As Integer
Select Case Mois
    Case 1, 3, 5, 7, 8, 10, 12
        DernierJour = 31
    Case 4, 6, 9, 11
        DernierJour = 30
    Case 2
        DernierJour = IIf(EstBissextile(Annee), 29, 28)
    Case Else
        DernierJour = 0 'cas d'une erreur
End Select
End Function

Function EstBissextile(Annee As Integer) As Boolean
EstBissextile = False
If Annee Mod 4 = 0 And (Annee Mod 100 <> 0 Or Annee Mod 400 = 0) Then EstBissextile = True
End Function

Function niemejourMois(num_jour As Integer, position_jour As Integer, mois As Integer, annee As Integer) As Date
Dim firstDayOfMonth As Integer
Dim DatefirstDayOfMonth As Date
    DatefirstDayOfMonth = CDate(Format(CDate("01/" & mois & "/" & annee), "dd/mm/YYYY"))
    firstDayOfMonth = Day(DatefirstDayOfMonth)

If num_jour = firstDayOfMonth And position_jour = 1 Then
    niemejourMois = firstDayOfMonth
Else
    If num_jour = firstDayOfMonth Then
        niemejourMois = DatefirstDayOfMonth + ((position_jour - 1) * 7)
    Else
        niemejourMois = DatefirstDayOfMonth + ((position_jour - 1) * 7) - firstDayOfMonth + num_jour
    End If
End If

End Function

Sub test()
' Date du Quatrième Mercredi du mois de décembre 2014 :
msgbox niemejourMois(3, 4, 12, 2014)
End Sub

Function listJoursduMois(num_jour As Integer, mois As Integer, annee As Integer, Optional filtreSemainePairImpair = "ALL") As Variant()
 Dim dateTmp As Date
 Dim L As Integer
 Dim numSemaine As Integer
 Dim arrListDateJofMonth()
 Dim firstDayOfMonth As Integer
 Dim DatefirstDayOfMonth As Date
 Dim DateLastDayOfMonth As Date
   DatefirstDayOfMonth = CDate(Format(CDate("01/" & mois & "/" & annee), "dd/mm/YYYY"))
   DateLastDayOfMonth = DateAdd("d", -1, DateAdd("m", 1, DatefirstDayOfMonth))
   firstDayOfMonth = Day(DatefirstDayOfMonth)
   L = 0
   dateTmp = DatefirstDayOfMonth
  
  Do
   'Debug.Print ("dateTmp : " & dateTmp & "  -- weekday(dateTmp): " & Weekday(dateTmp))
   If Weekday(dateTmp) - 1 = num_jour Then
       numSemaine = WeekNum(dateTmp)
       semainePair = (numSemaine Mod 2 = 0)
    Select Case filtreSemainePairImpair
        Case "ALL"
            L = L + 1
            ReDim Preserve arrListDateJofMonth(3, L)
            arrListDateJofMonth(0, L - 1) = dateTmp
            arrListDateJofMonth(1, L - 1) = numSemaine
            arrListDateJofMonth(2, L - 1) = semainePair

        Case "PAIR"
            
            If semainePair = True Then
                L = L + 1
                ReDim Preserve arrListDateJofMonth(3, L)
                arrListDateJofMonth(0, L - 1) = dateTmp
                arrListDateJofMonth(1, L - 1) = numSemaine
                arrListDateJofMonth(2, L - 1) = semainePair
            End If
        
        Case "IMPAIR"
             
            If semainePair = False Then
                L = L + 1
                ReDim Preserve arrListDateJofMonth(3, L)
                arrListDateJofMonth(0, L - 1) = dateTmp
                arrListDateJofMonth(1, L - 1) = numSemaine
                arrListDateJofMonth(2, L - 1) = semainePair
            End If
    End Select
    
  
   End If
   dateTmp = DateAdd("d", 1, dateTmp)
  Loop Until dateTmp >= DateLastDayOfMonth
    
 listJoursduMois = arrListDateJofMonth
  
End Function

Function WeekNum(D As Date) As Integer
     WeekNum = CInt(Format(D, "ww", 2))
End Function

Sub test2()
'Par exemple... Connaitre la date
' du  troisième mercredi du mois de novembre 2014
arrListJour = listJoursduMois(3, 11, 2014)
MsgBox arrListJour(0, 3 - 1)

'Par exemple... Connaitre la date
' du  jeudi du mois de novembre 2014 de la deuxieme semaine PAIR
arrListJour = listJoursduMois(4, 11, 2014, "PAIR")
 MsgBox arrListJour(0, 2 - 1)

'Par exemple... Connaitre la date
' du  jeudi du mois de novembre 2014 de la première semaine PAIR
arrListJour = listJoursduMois(4, 11, 2014, "PAIR")
 MsgBox arrListJour(0, 1 - 1)
End Sub