VBA conditions bases complexes avec deux

Le 15/01/2025 à 22:26

Bonjour à tous,

Je suis en train de devenir littéralement chèvre. Cela fait des heures au carré que j'essaie de résoudre mon problème que voici :

si l'email existe dans les deux tableaux, et si la personne a suivi la formation EXPERIENCE D'ACHAT EN PRATIQUE, alors il faut mettre Oui dans la colonne C de l'onglet TOUTE ENSEIGNE. Je suis conscient qu'une simple formule suffirait, mais j'ai besoin d'une automatisation en récurrence (quotidienne), et il y a d'autres modules avant et après (qui eux tournent bien). Quelqu'un aurait une idée d'où vient le problème ? un grand merci pour votre aide!

Sub ComparerEtRenseignerAvecConditions()
    Dim wsEnseigne As Worksheet, wsHistorique As Worksheet
    Dim lastRowEnseigne As Long, lastRowHistorique As Long
    Dim dictHistorique As Object
    Dim i As Long
    Dim tableauEnseigne As Variant, tableauResultat As Variant
    Dim tableauHistorique As Variant
    Dim valeurMessagerie As String

    ' Références aux feuilles
    Set wsEnseigne = ThisWorkbook.Worksheets("TOUTE ENSEIGNE")
    Set wsHistorique = ThisWorkbook.Worksheets("HISTORIQUE DE FORMATION")

    ' Initialiser un dictionnaire pour stocker les valeurs de HISTORIQUE DE FORMATION
    Set dictHistorique = CreateObject("Scripting.Dictionary")

    ' Désactiver les mises à jour d'écran et les calculs automatiques
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Déterminer les dernières lignes des deux feuilles
    lastRowEnseigne = wsEnseigne.Cells(wsEnseigne.Rows.Count, "B").End(xlUp).Row
    lastRowHistorique = wsHistorique.Cells(wsHistorique.Rows.Count, "B").End(xlUp).Row

    ' Charger les données de HISTORIQUE DE FORMATION dans un tableau
    If lastRowHistorique > 1 Then
        tableauHistorique = wsHistorique.Range("B2:C" & lastRowHistorique).Value
    Else
        MsgBox "La feuille HISTORIQUE DE FORMATION ne contient pas de données.", vbExclamation
        Exit Sub
    End If

    ' Remplir le dictionnaire à partir des données de HISTORIQUE DE FORMATION
    For i = 1 To UBound(tableauHistorique, 1)
        valeurMessagerie = CleanString(CStr(tableauHistorique(i, 1))) ' Colonne B
        If Not dictHistorique.exists(valeurMessagerie) Then
            dictHistorique.Add valeurMessagerie, CleanString(CStr(tableauHistorique(i, 2))) ' Colonne C
        End If
    Next i

    ' Charger les données de TOUTE ENSEIGNE dans un tableau
    If lastRowEnseigne > 1 Then
        tableauEnseigne = wsEnseigne.Range("B2:B" & lastRowEnseigne).Value
        ReDim tableauResultat(1 To UBound(tableauEnseigne, 1), 1 To 1) ' Colonne C seulement
    Else
        MsgBox "La feuille TOUTE ENSEIGNE ne contient pas de données.", vbExclamation
        Exit Sub
    End If

    ' Parcourir les données de TOUTE ENSEIGNE
    For i = 1 To UBound(tableauEnseigne, 1)
        valeurMessagerie = CleanString(CStr(tableauEnseigne(i, 1))) ' Colonne B

        If dictHistorique.exists(valeurMessagerie) Then
            If dictHistorique(valeurMessagerie) = "EXPERIENCE D'ACHAT EN PRATIQUE" Then
                tableauResultat(i, 1) = "OUI"
            Else
                tableauResultat(i, 1) = ""
            End If
        Else
            tableauResultat(i, 1) = ""
        End If
    Next i

    ' Écrire les résultats dans la colonne C
    wsEnseigne.Range("C2:C" & lastRowEnseigne).Value = tableauResultat

    ' Réactiver les mises à jour d'écran et les calculs automatiques
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    ' Libérer le dictionnaire
    Set dictHistorique = Nothing

    ' Message de confirmation
    MsgBox "Comparaison terminée. La colonne C a été mise à jour.", vbInformation
End Sub

'------------------------------------------------
' Fonction pour nettoyer une chaîne de caractères
'------------------------------------------------
Private Function CleanString(ByVal inputString As String) As String
    Dim tempString As String
    tempString = Trim(inputString) ' Supprime les espaces de début et fin
    tempString = Replace(tempString, Chr(160), "") ' Supprime les espaces insécables
    tempString = Replace(tempString, Chr(9), "") ' Supprime les tabulations
    tempString = Replace(tempString, Chr(13), "") ' Supprime les retours chariot
    tempString = Replace(tempString, Chr(10), "") ' Supprime les sauts de ligne
    CleanString = tempString
End Function
9fichier-cible-test2.zip (542.99 Ko)
Le 16/01/2025 à 00:41

bonjour,

Le problème, Tu ne mets dans ton historique que la première formation trouvée pour une adresse mail (et ce n'est pas toujours la formation que tu veux vérifier)

Une proposition de modification de ton code, tout en essayant de garder son esprit.

Sub ComparerEtRenseignerAvecConditions()
    Dim wsEnseigne As Worksheet, wsHistorique As Worksheet
    Dim lastRowEnseigne As Long, lastRowHistorique As Long
    Dim dictHistorique As Object
    Dim i As Long
    Dim tableauEnseigne As Variant, tableauResultat As Variant
    Dim tableauHistorique As Variant
    Dim valeurMessagerie As String

    ' Références aux feuilles
    Set wsEnseigne = ThisWorkbook.Worksheets("TOUTE ENSEIGNE")
    Set wsHistorique = ThisWorkbook.Worksheets("HISTORIQUE DE FORMATION")

    ' Initialiser un dictionnaire pour stocker les valeurs de HISTORIQUE DE FORMATION
    Set dictHistorique = CreateObject("Scripting.Dictionary")

    ' Désactiver les mises à jour d'écran et les calculs automatiques
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Déterminer les dernières lignes des deux feuilles
    lastRowEnseigne = wsEnseigne.Cells(wsEnseigne.Rows.Count, "B").End(xlUp).Row
    lastRowHistorique = wsHistorique.Cells(wsHistorique.Rows.Count, "B").End(xlUp).Row

    ' Charger les données de HISTORIQUE DE FORMATION dans un tableau
    If lastRowHistorique > 1 Then
        tableauHistorique = wsHistorique.Range("B2:C" & lastRowHistorique).Value
    Else
        MsgBox "La feuille HISTORIQUE DE FORMATION ne contient pas de données.", vbExclamation
        Exit Sub
    End If

    ' Remplir le dictionnaire à partir des données de HISTORIQUE DE FORMATION
    For i = 1 To UBound(tableauHistorique, 1)
        valeurMessagerie = CleanString(CStr(tableauHistorique(i, 1))) ' Colonne B
        If Not dictHistorique.exists(valeurMessagerie) Then
            formation = CleanString(CStr(tableauHistorique(i, 2)))
            'on ne met dans le dictionnaire que les personnes qui ont la formation EXPERIENCE ....
            If formation = "EXPERIENCE D'ACHAT EN PRATIQUE" Then
            dictHistorique.Add valeurMessagerie, formation ' Colonne C
        End If
    End If
Next i

' Charger les données de TOUTE ENSEIGNE dans un tableau
If lastRowEnseigne > 1 Then
    tableauEnseigne = wsEnseigne.Range("B2:B" & lastRowEnseigne).Value
    ReDim tableauResultat(1 To UBound(tableauEnseigne, 1), 1 To 1) ' Colonne C seulement
Else
    MsgBox "La feuille TOUTE ENSEIGNE ne contient pas de données.", vbExclamation
    Exit Sub
End If

' Parcourir les données de TOUTE ENSEIGNE
For i = 1 To UBound(tableauEnseigne, 1)
    valeurMessagerie = CleanString(CStr(tableauEnseigne(i, 1))) ' Colonne B
    tableauResultat(i, 1) = ""
    If dictHistorique.exists(valeurMessagerie) Then
        tableauResultat(i, 1) = "OUI"
        End If
    Next i

    ' Écrire les résultats dans la colonne C
    wsEnseigne.Range("C2:C" & lastRowEnseigne).Value = tableauResultat

    ' Réactiver les mises à jour d'écran et les calculs automatiques
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    ' Libérer le dictionnaire
    Set dictHistorique = Nothing

    ' Message de confirmation
    MsgBox "Comparaison terminée. La colonne C a été mise à jour.", vbInformation
End Sub
Le 16/01/2025 à 00:53

Salut AlainDeg,

quelque chose ainsi ?
Un double-clic sur la feuille 'TOUTE ENSEIGNE' démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTabTE, tTabHF
'
Cancel = True
tTabTE = Range("B2:C" & Range("B" & Rows.Count).End(xlUp).Row).Value
With Worksheets("HISTORIQUE DE FORMATION")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    .Range("A2:C" & .Range("B" & Rows.Count).End(xlUp).Row).AutoFilter _
        field:=3, Criteria1:="EXPERIENCE D'ACHAT EN PRATIQUE"
    tTabHF = .Range("B2:C" & .Range("B" & Rows.Count).End(xlUp).Row).Value
End With
'
If UBound(tTabTE, 1) > 0 And UBound(tTabHF, 1) > 0 Then
    For x = 1 To UBound(tTabTE, 1)
        For y = 1 To UBound(tTabHF, 1)
            If tTabHF(y, 1) = tTabTE(x, 1) Then
                If InStr(tTabHF(y, 2), "EXPERIENCE D'ACHAT EN PRATIQUE") > 0 Then tTabTE(x, 2) = "OUI"
                Exit For
            End If
        Next
    Next
    Range("B2").Resize(UBound(tTabTE, 1), 2).Value = tTabTE
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Range("A2:C" & Range("B" & Rows.Count).End(xlUp).Row).AutoFilter _
        field:=3, Criteria1:="Oui"
End If
'
End Sub

A+

9alaindeg.xlsm (622.50 Ko)
Rechercher des sujets similaires à "vba conditions bases complexes deux"