VBA et excel : suppression de lignes correspondantes

VBA et excel : suppression de lignes correspondantes - VB/VBA/VBS - Programmation

Marsh Posté le 10-06-2009 à 16:21:23    

Bonjour,
 
Débutant en matière de vba, je vous sollicite pour combler mon newbisme.
 
Mon problème est le suivant : j'ai deux feuilles excel, et le but est de supprimer les lignes de la première qui sont contenues dans la deuxième. Plus précisément il s'agit d'enlever les duo nom+prénom qui correspondent.  
 
Petite complication : sur la première feuille l'information est regroupée sur deux cellules (nom + prénom) alors qu'elle l'est dans une seule même sur la deuxième feuille.
 
Voici mon code pour le moment :
 

Code :
  1. set Tabl1 = Worksheets(1).Range("B2",[B2].End(xlDown))
  2. Set Tabl2 = Worksheets(2).Range("E2",[E2].End(xlDown))
  3. Set Tabl3 = Worksheets(1).Range("H2",[H2].End(xlDown))
  4. DerniereLigne1 = Worksheets(1).UsedRange.Rows.Count
  5. DerniereLigne2 = Worksheets(2).UsedRange.Rows.Count
  6. For R = 1 To DerniereLigne1 Step 1
  7. Dim a As Variant
  8.  a = Split(Worksheets(2).Range(R)," " )
  9. For P = 1 To DerniereLigne2 Step 1
  10.       If Table2(P).contains(a(0)) And Tabl3(P).Contains(a(1)) then Rows(P).Delete
  11. Next P
  12. Next R


Quelqu'un serait-il en mesurer de m'éclairer ? Merci par avance.
 

Reply

Marsh Posté le 10-06-2009 à 16:21:23   

Reply

Marsh Posté le 10-06-2009 à 19:29:24    


Hi,
 
Il m'a l'air bien compliqué ton code  ;)
 
Un peu plus long mais plus clair (enfin je crois), les choses à changer pour l'adaptation à ton fichier sont en bordeaux :
 

Citation :


Dim NbLigneSheet1, NbLigneSheet2, LigneDbtData1, LigneDbtData2, a, b As Integer
Dim F1, F2 As Object
 
'Procédure principale
Sub SuppressionLignes()
 
'On appelle les procédures qui initialisent les variables
Call InitVar
Call CalculNbLignes
 
'On parcourt la première feuille
For a = LigneDbtData1 To NbLigneSheet1
 
'Pour chaque ligne de la première feuille, on parcourt complètement la deuxième feuille
For b = LigneDbtData2 To NbLigneSheet2
 
'On compare les contenus des deux feuilles
VarNom = F1.Range("B" & a) & " " & F1.Range("C" & a)
 
If VarNom = F2.Range("D" & b) Then
 
'En cas de correspondance on supprime la ligne correspondante dans la deuxième feuille
F2.Range("A" & b).Select
Selection.EntireRow.Delete
'Ne pas oublier de décrémenter b sinon on zappe une ligne
b = b - 1
 
End If
 
Next b
Next a
 
End Sub
 
 
'Cette procédure sert à regrouper les variables à initialiser
Sub InitVar()
 
Set F1 = Sheet1
Set F2 = Sheet2
LigneDbtData1 = 3
LigneDbtData2 = 3
 
 
End Sub
 
'Cette procédure permet de calculer le nombre de lignes dans les tableaux contenant les noms
Sub CalculNbLignes()
 
F1.Select
NbLigneSheet1 = Range("B65536" ).End(xlUp).Row
 
F2.Select
NbLigneSheet2 = Range("D65536" ).End(xlUp).Row
 
End Sub
 


 
 


---------------
"That kind of information doesn't just grow on trees."
Reply

Marsh Posté le 10-06-2009 à 22:50:38    

Merci de faire profiter de ta science :)  
 
à+

Reply

Marsh Posté le 10-03-2012 à 11:47:03    

Bonjour Ctplm,
 
Après des recherches intenses (!) sur les forums je découvre votre code qui correspond quasiment à ce dont j'ai besoin.
Sauf que j'ai voulu l'adapter un peu car moi je souhaite qu'en cas de correspondance on supprime la ligne correspondante dans la deuxième feuille ET dans la première feuille avant de reprendre la boucle. Mais je n'y arrive pas.
 
Pouvez-vous m'aider sur ce point ?
 
Par avance merci ;-)
 

Reply

Marsh Posté le 11-03-2012 à 19:32:11    

Bonjour,

 

hum si tu supprimes en même temps dans les 2 feuilles tu perds de l'information. Je stock donc tes noms dans la feuille 3.

 
Citation :

Sub main()

 

Dim i As Integer, j As Integer
Dim sheet1_name As String, sheet2_name As String, sheet3_name As String, name As String
Dim delete As Boolean

 

sheet1_name = "Feuil1"
sheet2_name = "Feuil2"
sheet3_name = "Feuil3"

 

'stock name sheet1 in sheet3 col1
With ThisWorkbook.Worksheets(sheet1_name)
    For i = 1 To .Cells(1, 1).End(xlDown).Row
        ThisWorkbook.Worksheets(sheet3_name).Cells(i, 1).Value = .Cells(i, 1).Value
    Next i
End With
'stock name sheet2 in sheet3 col2
With ThisWorkbook.Worksheets(sheet2_name)
    For i = 1 To .Cells(1, 1).End(xlDown).Row
        ThisWorkbook.Worksheets(sheet3_name).Cells(i, 2).Value = .Cells(i, 1).Value
    Next i
End With

 

'delete sheet1
With ThisWorkbook.Worksheets(sheet1_name)
    For i = .Cells(1, 1).End(xlDown).Row To 1 Step -1
        name = .Cells(i, 1).Value
        delete = False
        With ThisWorkbook.Worksheets(sheet3_name)
            For j = .Cells(1, 2).End(xlDown).Row To 1 Step -1
                If name = .Cells(j, 2).Value Then
                    delete = True
                    Exit For
                End If
            Next j
        End With
        If delete = True Then .Rows(i).delete
    Next i
End With

 

'delete sheet2
With ThisWorkbook.Worksheets(sheet2_name)
    For i = .Cells(1, 1).End(xlDown).Row To 1 Step -1
        name = .Cells(i, 1).Value
        delete = False
        With ThisWorkbook.Worksheets(sheet3_name)
            For j = .Cells(1, 1).End(xlDown).Row To 1 Step -1
                If name = .Cells(j, 1).Value Then
                    delete = True
                    Exit For
                End If
            Next j
        End With
        If delete = True Then .Rows(i).delete
    Next i
End With

 

End Sub

 

Edit: Faut que je poste une autre version avec dico, ces  boucles imbriquée me tracassent  [:transparency]

 
Citation :

Sub main2()

 

Dim i As Integer
Dim sheet1_name As String, sheet2_name As String
Dim sname As Variant
Dim dico As Scripting.Dictionary

 

Set dico = New Scripting.Dictionary
sheet1_name = "Feuil1"
sheet2_name = "Feuil2"
dico(sheet1_name) = sheet2_name
dico(sheet2_name) = sheet1_name

 

For Each sname In Array(sheet1_name, sheet2_name)
    With ThisWorkbook.Worksheets(sname)
        For i = 1 To .Cells(1, 1).End(xlDown).Row
            dico(sname & .Cells(i, 1).Value) = i
        Next i
    End With
Next sname

 

For Each sname In Array(sheet1_name, sheet2_name)
    With ThisWorkbook.Worksheets(sname)
        For i = .Cells(1, 1).End(xlDown).Row To 1 Step -1
            If dico.Exists(dico(sname) & .Cells(i, 1).Value) = True Then .Rows(i).delete
        Next i
    End With
Next sname

 


Set dico = Nothing
End Sub


Message édité par tarteflambee le 11-03-2012 à 19:55:18
Reply

Marsh Posté le 19-03-2012 à 20:36:24    

Impeccable !!
Merci tarteflambee
  :)


Message édité par 2lester le 19-03-2012 à 20:37:08
Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed