Condition supplémentaire en VBA (.Find)

Le 16/11/2021 à 10:31

Bonjour à tous,

Je nécessite votre aide pour rajouter une condition supplémentaire à ma macro sans pour autant tout crasher.

La macro de base analyse la base de données de A1:O950 pour me trouver les données en doublons mais de signe négatif avec ceux en signe positif en se basant sur la colonne G.

Par exemple si j'ai en G6 : -556 et en G9 : 556, elle va importer l'ensemble des deux lignes dans une feuille nommée BDD.

Par contre j'aimerais rajouter une fonctionnalité c'est de comparer également le code relatif à chaque montant, ce dernier étant en colonne "D" et ayant pour architecture 6 int et 1 string par exemple : 458315A ou A398743 (le string toujours en début ou fin). Si le code des deux montants est similaire alors la condition est validée.

Sub Traitement1()
Dim c As Variant
Dim firstAddress As String
Dim firstlign As Integer
Dim mavar As String
Dim Rg_Ligne As Range, Rg_Total As Range
Dim tablo(2000)
Dim num As Boolean
'Dim test
For i = 2 To 2000
'test = num
    Set Rg_Total = ActiveSheet.Range("A2:O2")
    With Worksheets("Versements").Range("G:G")
        mavar = Range("G" & i)
        Set c = .Find(mavar, LookIn:=xlValues, Lookat:=xlPart)
        If Not c Is Nothing Then
            firstAddress = c.Address
            firstlign = c.Row
            Do
                If mavar = WorksheetFunction.ImAbs(c.Value) Then
                    If mavar > 10 Then
                        If c.Row <> firstlign Then
                            tablo(c.Row) = c.Row
                            num = True
                        End If
                     End If
                End If
            Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
        If num = True Then tablo(firstlign) = firstlign    ' : Range("G" & firstlign).Clear
    End With
    num = False
Next i
For x = 2 To 2000
    If tablo(x) <> "" Then
        Set Rg_Ligne = ActiveSheet.Range("A" & tablo(x) & ":O" & tablo(x))
        Set Rg_Total = Application.Union(Rg_Total, Rg_Ligne)
    End If
Next x
Rg_Total.Copy Sheets("BDD").Range("a1")
Rg_Total.EntireRow.Delete
End Sub

En vous remerciant d'avance, bonne journée à tous.

Le 16/11/2021 à 11:56

bonjour,

une proposition (non testée)

Sub Traitement1()
    Dim c As Variant
    Dim firstAddress As String
    Dim firstlign As Integer
    Dim mavar As String, maref As String
    Dim Rg_Ligne As Range, Rg_Total As Range
    Dim tablo(2000)
    Dim num As Boolean
    'Dim test
    For i = 2 To 2000
        'test = num
        Set Rg_Total = ActiveSheet.Range("A2:O2")
        With Worksheets("Versements").Range("G:G")
            mavar = Range("G" & i)
            maref = Range("D" & i)
            Set c = .Find(mavar, LookIn:=xlValues, Lookat:=xlPart)
            If Not c Is Nothing Then
                firstAddress = c.Address
                firstlign = c.Row
                Do
                    If mavar = WorksheetFunction.ImAbs(c.Value) Then
                        If maref = Range("D" & c.Row) Then
                            If mavar > 10 Then
                                If c.Row <> firstlign Then
                                    tablo(c.Row) = c.Row
                                    num = True
                                End If
                            End If
                        End If
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
            If num = True Then tablo(firstlign) = firstlign    ' : Range("G" & firstlign).Clear
        End With
        num = False
    Next i
    For x = 2 To 2000
        If tablo(x) <> "" Then
            Set Rg_Ligne = ActiveSheet.Range("A" & tablo(x) & ":O" & tablo(x))
            Set Rg_Total = Application.Union(Rg_Total, Rg_Ligne)
        End If
    Next x
    Rg_Total.Copy Sheets("BDD").Range("a1")
    Rg_Total.EntireRow.Delete
End Sub
Le 16/11/2021 à 12:15

Bonjour,

Je viens de tester votre proposition mais les résultats sont les mêmes qu'avec ma macro.

Bien à vous

Le 16/11/2021 à 12:26

bonjour,

Je viens de tester votre proposition mais les résultats sont les mêmes qu'avec ma macro

Je ne peux absolument rien faire d'une telle réponse.

Si tu fournis le fichier (ou un fichier exemple représentatif de ton fichier) dans lequel on peut reproduire le problème, je veux bien regarder.

je m'interroge sur l'utilité du imabs, sur le fait que myvar soit définie comme string, le fait que tes instructions range ne soient pas qualifiées, ...

Le 16/11/2021 à 15:05
10samplexlsx.xlsx (13.97 Ko)

Re

Voilà un exemple de la représentation de la base de données. Je tiens à préciser que les seules colonnes que je dois utiliser dans ma macro sont la colonne D et la colonne G.

Merci encore,

Le 20/11/2021 à 20:01

Bonsoir à tous

Je suis très intéressé par la macro de Valjean. Pourrais-tu annoter ta macro pour que je puisse comprendre ?

Merci d'avance

Le 21/11/2021 à 00:40

bonsoir,

il me semblait avoir posté cette réponse mardi.

Sub Traitement1()
    Dim c As Variant
    Dim firstAddress As String
    Dim firstlign As Integer
    Dim mavar As Double, maref As String, ctr As Long, dl As Long, i As Long
    Dim Rg_Ligne As Range, Rg_Total As Range
    Dim wsv
    Dim num As Boolean
    Dim tablo()
    Set wsv = Sheets("versements")
    dl = wsv.UsedRange.Rows.Count
    ReDim tablo(dl)
    ctr = 0
    With Worksheets("Versements")
        .Range("A1:O1").Copy Sheets("BDD").Range("A1")
        For i = 2 To dl
            mavar = .Range("G" & i)
            maref = .Range("D" & i)
            Set c = .Range("G2").Resize(dl, 1).Find(-mavar, LookIn:=xlValues, Lookat:=xlWhole) 'recherche d'un montant opposé
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    If maref = .Range("D" & c.Row) Then 'même référence
                        If mavar > 10 Then ' pourquoi ce test ?
                                ctr = ctr + 1
                                tablo(ctr) = i
                                ctr = ctr + 1
                                tablo(ctr) = c.Row
                                Exit Do
                        End If
                    End If
                    Set c = .Range("G2").Resize(dl, 1).FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        Next i
        For i = 1 To ctr
            If tablo(i) <> "" Then
                Set Rg_Ligne = .Range("A" & tablo(i) & ":O" & tablo(i))
                If Rg_Total Is Nothing Then
                    Set Rg_Total = Rg_Ligne
                Else
                    Set Rg_Total = Application.Union(Rg_Total, Rg_Ligne)
                End If
            End If
        Next i
    End With
    Rg_Total.Copy Sheets("BDD").Range("a2")
    Rg_Total.EntireRow.Delete 'supprimer les lignes copiées
End Sub
Le 21/11/2021 à 15:11

Bonjour à tous

Désolé h2so4, je me suis mal exprimé, c'est à Valjean que je demandais les annotations, puisque c'est SA macro.

J'attends avec impatience les annotations de Valjean.

Rechercher des sujets similaires à "condition supplementaire vba find"