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 :
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
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.
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.
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.