VBA - générer une action si première occurence

Bonjour,

Je viens de développer une macro qui ne fonctionne pas. Je souhaiterais inscrire en colonne C, à droite de la premiere occurrence du numero de dossier (colonne B) le chiffre 1. Pour toutes les autres occurrences du même numéro de dossier je souhaite inscrire le chiffre 0.

De sorte que :

tableau

J'ai conscience que je ne suis pas obligé de passer par une macro de ce type pour ce genre d'exercice mais cela rentre dans le cadre d'un projet VBA beaucoup plus large et ceci n'est que la première étape.

Sub Bouton2_Cliquer()

    Set ZoneNum = ActiveWorkbook.Sheets("Feuil2").Range("B1").End(xlDown)
    Set c = ZoneNum.Find(num_enveloppe, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not c Is Nothing Then
        firstAdressInit = c.Row
        j = 0

        While num_enveloppe = Cells(firstAdressInit + j, 2)
        reporting = Cells(1 + j, 3).Value

            If j = 0 Then
            reporting = 1
            Else
            reporting = 0
            End If

        j = j + 1

        Wend

    End If

End Sub
45testvba.xlsm (394.42 Ko)

Bonjour,

Essayer :

Sub Bouton2_Cliquer()
    Dim d As Object, k, n&, i&
    Set d = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("Feuil2")
        n = .Range("B" & .Rows.Count).End(xlUp).Row
        For i = 1 To n
            d(.Cells(i, 2).Value) = ""
        Next i
        Application.ScreenUpdating = False
        .Range("C1:C" & n).Value = 0
        For Each k In d.keys
            i = WorksheetFunction.Match(k, .Columns("B"), 0)
            .Cells(i, 3) = 1
        Next k
        .Activate
    End With
End Sub

Cordialement.

41thibier1-testvba.xlsm (396.38 Ko)

Effectivement, cela semble bien marcher. Est ce que du coup tu pourrais m'aider à élaborer une macro pour faire ceci ? :

Dans le fichier vbatest1 tu trouveras des informations relative à des numéros de dossier.

Dans le fichier vbatest2 tu trouveras des informations relative à des numéros de dossier également.

Certains dossiers comportent des informations totalement équivalentes entre vbatest1 et vbatest2 : même nombre de lignes, même valeurs pour chaque cellules.

D'autres dossiers ont vu une ligne s'ajouter entre le dossier test1 et test2 ou la valeur d'une cellule modifiée entre test1 et test2. Ces changements apparaissent en jaune dans le fichier test2 pour une meilleur visibilité mais ne sont évidemment pas en jaune en principe.

Est ce que tu pourrais m'aider à développer une macro vba dans le fichier vbatest3 ou j'aurais un tableau qui indique un changement d'information entre le vbatest1 et vbatest2 ? Tu trouveras le tableau créer "à la main" dans vbatest3 qui indique le résultat que je souhaite obtenir.

Bien cordialement.

15vbafichier1.xlsx (335.15 Ko)
14vbafichier2.xlsx (9.47 Ko)
11vbafichier3.xlsx (10.17 Ko)

Bonsoir et meilleurs voeux,

Sub Comparer()
    Dim d1 As Object, d2 As Object, n%, i%, doss$, dos, k
    Set d1 = CreateObject("Scripting.Dictionary")
    With Workbooks.Open(ThisWorkbook.Path & "\vbafichier1.xlsx").Worksheets(1)
    'With Workbooks("vbafichier1.xlsx").Worksheets(1)
        n = .Cells(.Rows.Count, 2).End(xlUp).Row
        .Range("B1:D" & n).Sort key1:=.Range("B1"), order1:=xlAscending, Header:=xlNo
        For i = 1 To n
            doss = doss & ";" & .Cells(i, 3) & ";" & .Cells(i, 4)
            If .Cells(i + 1, 2) <> .Cells(i, 2) Then
                d1(.Cells(i, 2).Value) = doss: doss = ""
            End If
        Next i
    End With
    Workbooks("vbafichier1.xlsx").Close False
    Set d2 = CreateObject("Scripting.Dictionary")
    With Workbooks.Open(ThisWorkbook.Path & "\vbafichier2.xlsx").Worksheets(1)
    'With Workbooks("vbafichier2.xlsx").Worksheets(1)
        n = .Cells(.Rows.Count, 2).End(xlUp).Row
        .Range("B1:D" & n).Sort key1:=.Range("B1"), order1:=xlAscending, Header:=xlNo
        For i = 1 To n
            doss = doss & ";" & .Cells(i, 3) & ";" & .Cells(i, 4)
            If .Cells(i + 1, 2) <> .Cells(i, 2) Then
                d2(.Cells(i, 2).Value) = doss: doss = ""
            End If
        Next i
    End With
    Workbooks("vbafichier2.xlsx").Close False
    For Each k In d1.keys
        doss = d1(k)
        If d2.exists(k) Then
            dos = Split(d2(k), ";")
            For i = 1 To UBound(dos)
                If InStr(1, doss, dos(i)) > 0 Then
                    doss = Replace(doss, dos(i), "", 1, 1)
                    dos(i) = ""
                End If
            Next i
            doss = Trim(Replace(doss, ";", ""))
            If doss <> "" Then
                d1(k) = "Différent"
            Else
                If Trim(Join(dos)) <> "" Then
                    d1(k) = "Différent"
                Else
                    d1(k) = "Identique"
                End If
            End If
            d2.Remove (k)
        Else
            d1(k) = "Fichier 1 slt"
        End If
    Next k
    n = d1.Count
    With ThisWorkbook.Worksheets(1)
        Application.ScreenUpdating = False
        .UsedRange.Clear
        .Range("A1:A" & n).Value = WorksheetFunction.Transpose(d1.keys)
        .Range("B1:B" & n).Value = WorksheetFunction.Transpose(d1.items)
        If d2.Count > 0 Then
            .Range("A" & n + 1).Resize(d2.Count).Value = _
             WorksheetFunction.Transpose(d2.keys)
            .Range("B" & n + 1).Resize(d2.Count).Value = "Fichier 2 slt"
        End If
        n = n + d2.Count
        For i = 1 To n
            If .Cells(i, 2) <> "Identique" Then .Cells(i, 2).Font.Bold = True
        Next i
    End With
End Sub

Les lignes désactivées sont à activer (et celle qui précède à désactiver) si classeurs déjà ouverts.

Les classeurs sont supposés dans le même dossier.

Faire en sorte que les éléments à comparer soient sur la première feuille (sinon modifier le code...)

Cordialement.

Rechercher des sujets similaires à "vba generer action premiere occurence"