Définir une plage de feuille VBA Résolu

Question

Bonjour, 

Je suis devant un problème anodin, car après plusieurs année de coupure je ne rappel plus comment définir la plage des cellules de la colonne B à la place de A.
J'ai je réutiliser mon ancien code tout en vérifiant les éléments dans les cellule B.
Ci dessous mon code:


Sub Reference()

    Dim PlageFE_1 As Range
    Dim PlageFE_2 As Range
    Dim CelFE_1 As Range
    Dim CelFE_2 As Range
    Dim DerCel As Long
    
    'défini les plages en colonne A de Feuil1 et Feuil2
    With Worksheets("Feuil1")
    
        Set PlageFE_1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    
    End With
    
    With Worksheets("Feuil2")
    
        Set PlageFE_2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        
        'mémorise la dernière ligne occupée
        DerCel = .Cells(.Rows.Count, 1).End(xlUp).Row
        
    End With
    
    'boucle sur la plage en Feuil1 et recherche la valeur en Feuil2
    'si pas trouvée, rajoute la ligne à Feuil2 puis colore (cellules non vides) en rouge
    For Each CelFE_1 In PlageFE_1
    
        Set CelFE_2 = PlageFE_2.Find(CelFE_1, , xlValues, xlWhole)
        
        If CelFE_2 Is Nothing Then
        
            DerCel = DerCel + 1
            
            With Worksheets("Feuil2")
            
                CelFE_1.EntireRow.Copy .Range("A" & DerCel)
                .Range(.Cells(DerCel, 1), .Cells(DerCel, .Columns.Count).End(xlToLeft)).Interior.ColorIndex = 3
                
            End With
            
        End If
        
    Next CelFE_1
    
    'boucle sur la plage en Feuil2 et recherche la valeur en Feuil1
    'si pas trouvée, colore la ligne (cellules non vides) en jaune
    For Each CelFE_2 In PlageFE_2
    
        Set CelFE_1 = PlageFE_1.Find(CelFE_2, , xlValues, xlWhole)
        
        If CelFE_1 Is Nothing Then
        
            With Worksheets("Feuil2")
            
                .Range(.Cells(CelFE_2.Row, 1), .Cells(CelFE_2.Row, .Columns.Count).End(xlToLeft)).Interior.ColorIndex = 6
                
            End With
            
        End If
        
    Next CelFE_2

End Sub


Merci pour votre assistance.

Configuration: Windows 7 / Chrome 21.0.1180.83

michel_m · Accepted Answer

Bonjour  
juste après l'aube ou presque :o)

proposition:  
durée avec proc 2ghz ram 512: >=11 secondes 
macro dans module1 et non module feuille (erreur dangereuse) 

Option Explicit  
Option Base 1  
Const Dercol As Integer = 8 'n° de la dernière colonne utilisée  

Sub alter_reference()  
Dim Derlig1 As Long, Derlig2 As Long  
Dim Cptr As Integer, T1_colb(), T2_colb  
Dim Dico1 As Object, Dico2 As Object  
Dim T_out(), Nbre As Long, Col As Byte  
Dim Start As Single, Duree As Single 'pour essai rapidité  

Start = Timer  

'fige le défilement de l'écran  
Application.ScreenUpdating = False  

'ipréparations feuil1  
With Sheets("feuil1")  
     Derlig1 = .Cells(.Rows.Count, 2).End(xlUp).Row  
     'passage en ram tableau feuille1  
     T1_colb = .Range(.Cells(1, 1), .Cells(Derlig1, Dercol)).Value  
     'création du dictionnary feuille1 col b  
     Set Dico1 = CreateObject("scripting.dictionary")  
          For Cptr = 1 To UBound(T1_colb)  
               If Not Dico1.exists(T1_colb(Cptr, 2)) Then 'élimination des éventuels doublons  
                    Dico1.Add T1_colb(Cptr, 2), ""  
               End If  
          Next  
End With  

With Sheets("feuil2")  
'initialisations et préparations feuil2  
     Derlig2 = .Cells(.Rows.Count, 2).End(xlUp).Row  
     .Range(.Cells(1, 1), .Cells(Derlig2, Dercol)).Interior.ColorIndex = xlNone  
     'passage en ram tableau feuil2  
     T2_colb = .Range(.Cells(1, 1), .Cells(Derlig2, Dercol)).Value  
     'création du dictionnary feuille1 col b  
     Set Dico2 = CreateObject("scripting.dictionary")  
          For Cptr = 1 To UBound(T2_colb)  
                If Not Dico2.exists(T2_colb(Cptr, 2)) Then 'élimination des éventuels doublons  
                    Dico2.Add T2_colb(Cptr, 2), ""  
               End If  
          Next  
     
'détecte les éléments de feuil2 manquant en feuil1 _  
     et les colorise en jaune  
     For Cptr = 1 To UBound(T2_colb)  
          If Not Dico1.exists(T2_colb(Cptr, 2)) Then  
               .Range(.Cells(Cptr, 1), .Cells(Cptr, Dercol)).Interior.ColorIndex = 6  
          End If  
     Next  

'mémorise les éléments de feuil1 manquant en feuil2 _  
     et les retranscrit  dans la feuille 2 et les colorise en rouge  
     Nbre = 1  
     ReDim T_out(Dercol, Nbre)  
     'mémorisation  
     For Cptr = 1 To UBound(T1_colb)  
          If Not Dico2.exists(T1_colb(Cptr, 2)) Then  
               For Col = 1 To Dercol  
                    T_out(Col, Nbre) = T1_colb(Cptr, Col)  
               Next  
               Nbre = Nbre + 1  
               ReDim Preserve T_out(Dercol, Nbre)  
          End If  
     Next  
     ReDim Preserve T_out(Dercol, Nbre - 1) 
  'restitution  
     With .Cells(Derlig2 + 1, 1).Resize(Nbre - 1, Dercol)  
          .Value = Application.Transpose(T_out)  
          .Interior.ColorIndex = 3  
     End With  
     .Activate  
End With  

'pour essai  
Duree = Timer - Start  
Application.ScreenUpdating = False  
MsgBox ("durée: " & Duree & " secondes")  

End Sub  
   
   
 Michel

f894009 · Answer

Bonjour,

Cells(1,1)==>A1
Cells(1,2)==>B1

Baajo · Answer

En effet c'est ça, sauf que je n'arrive pas définir la plage des cellules de la colonne  B à la place de A.

Merci d'avance.

pilas31 · Answer

Bonjour,

Je propose la traduction suivante :
Sub Reference()

    Dim PlageFE_1 As Range
    Dim PlageFE_2 As Range
    Dim CelFE_1 As Range
    Dim CelFE_2 As Range
    Dim DerCel As Long
    
    'défini les plages en colonne B de Feuil1 et Feuil2
    With Worksheets("Feuil1")
    
        Set PlageFE_1 = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
    
    End With
    
    With Worksheets("Feuil2")
    
        Set PlageFE_2 = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
        
        'mémorise la dernière ligne occupée
        DerCel = .Cells(.Rows.Count, 2).End(xlUp).Row
        
    End With
    
    'boucle sur la plage en Feuil1 et recherche la valeur en Feuil2
    'si pas trouvée, rajoute la ligne à Feuil2 puis colore (cellules non vides) en rouge
    For Each CelFE_1 In PlageFE_1
    
        Set CelFE_2 = PlageFE_2.Find(CelFE_1, , xlValues, xlWhole)
        
        If CelFE_2 Is Nothing Then
        
            DerCel = DerCel + 1
            
            With Worksheets("Feuil2")
            
                CelFE_1.EntireRow.Copy .Range("A" & DerCel)
                .Range(.Cells(DerCel, 2), .Cells(DerCel, .Columns.Count).End(xlToLeft)).Interior.ColorIndex = 3
                
            End With
            
        End If
        
    Next CelFE_1
    
    'boucle sur la plage en Feuil2 et recherche la valeur en Feuil1
    'si pas trouvée, colore la ligne (cellules non vides) en jaune
    For Each CelFE_2 In PlageFE_2
    
        Set CelFE_1 = PlageFE_1.Find(CelFE_2, , xlValues, xlWhole)
        
        If CelFE_1 Is Nothing Then
        
            With Worksheets("Feuil2")
            
                .Range(.Cells(CelFE_2.Row, 2), .Cells(CelFE_2.Row, .Columns.Count).End(xlToLeft)).Interior.ColorIndex = 6
                
            End With
            
        End If
        
    Next CelFE_2

End Sub

 
A+

Baajo · Answer

Merci pilas31, c'est la bonne.
Maintenant je m'attaque à un autre problème sur le même fichier, c'est que quant je lance la macro dans un tableau excel de plus de 3000 lignes, la boucle se lance ais c'est sans fin, à chaque fois je suis obliger d'arrêter la macro.
Avez vous une solution à ça?
Merci

pilas31 · Answer

Bonjour,

C'est curieux, il n'y a que des boucles for each dans une plage de cellules qui est forcément bornée. Donc celà ne me semble pas pouvoir boucler.

J'ai fait le test avec 3600 lignes et ça fonctionne chez moi.

N'y a t-il que cette macro qui se lance ?

Baajo · Answer

Oui il y a qu'une seule macro qui est lancée.
Avec une nouvelle tentative, cette dernière à ramé plus de 15 min avant que je l'arrête de nouveau

michel_m · Answer

Bonjour,

Pilas, excuse l'inscruste (perso: beau temps à villeneuve Today)

Avec 30000 et 3000  lignes sans écran figé et en recopiant des cellules, il n'est pas étonnant que tu mettes un temps fou !...
Il faudrait passer par des objets dictionary et des variables tableaux pour avoir une durée raisonnable

petite question car tu as joint un classeur modèle que je n'ai pas pu ouvrir: quel est le nombre de colonnes maxi ?

je pars vers 14,30h et reviendrais en fin d'aprèm

pilas31 · Answer

Re  

J'ai pensé à une autre méthode que je vous décris rapidement :  

1/ Sur chaque ligne de la feuille 1 je mets 1 en colonne 10 et le n° de ligne en colonne 11. Idem sur la feuille 2 avec 2 en colonne 10 et le n° de ligne en colonne 11.  

2/Je copie les lignes de la feuille 1 et les lignes de la feuille 2 à la suite dans la feuille3  

3/ Je trie la feuille 3 selon le code (colonne B)  

4/ je supprime les doublons car cela signifie qu'ils sont dans les deux feuilles  

5/ Ceux qui restent si ils ont 1 en colonne 10 c'est qu'ils sont dans la feuille1 et pas dans la feuille 2. Si ils ont 2 c'est le contraire.  

Voila le code. J'ai testé et il traite le fichier en 4 minutes environ chez moi. Je pense que ce n'est pas trop mal :  

Sub AUTRE()  
Dercel1 = Feuil1.Cells(Rows.Count, 2).End(xlUp).Row  
DerCel2 = Feuil2.Cells(Rows.Count, 2).End(xlUp).Row  
For Ligne1 = 2 To Dercel1  
    Feuil1.Cells(Ligne1, 10) = 1  
    Feuil1.Cells(Ligne1, 11) = Ligne1  
Next Ligne1  
For Ligne2 = 2 To DerCel2  
    Feuil2.Cells(Ligne2, 10) = 2  
    Feuil2.Cells(Ligne2, 11) = Ligne2  
Next Ligne2  

Sheets("Feuil1").Select  
Rows(2 & ":" & Dercel1).Select  
Selection.Copy  
Sheets("Feuil3").Select  
Rows("1:1").Select  
ActiveSheet.Paste  

Sheets("Feuil2").Select  
Rows(2 & ":" & DerCel2).Select  
Selection.Copy  
Sheets("Feuil3").Select  
Rows(Dercel1).Select  
ActiveSheet.Paste  
' on trie la feuille3  
With ActiveWorkbook.Worksheets("Feuil3").Sort  
    .SetRange Range("A1:K" & Dercel1 + DerCel2 - 2)  
    .MatchCase = False  
    .Orientation = xlTopToBottom  
    .SortMethod = xlPinYin  
    .Apply  
End With  
' on enlève les doublons  
For Ligne = Dercel1 + DerCel2 - 2 To 2 Step -1  
    If Cells(Ligne, 2) = Cells(Ligne - 1, 2) Then  
        Rows(Ligne & ":" & Ligne - 1).Select  
        Selection.Delete Shift:=xlUp  
    End If  
Next Ligne  
' toutes les lignes avec 1 en colonne 10 sont celles présentes en feuil1 et pas en feuil2  
' Toutes celles avec 2 c'est le contraire  
Derligne = Feuil3.Cells(Rows.Count, 2).End(xlUp).Row  
For Ligne = 1 To Derligne  
    If Cells(Ligne, 10) = 1 Then  
        DerCel2 = DerCel2 + 1  
        Ligne1 = Cells(Ligne, 11)  
        With Worksheets("Feuil2")  
            Feuil1.Cells(Ligne1, 1).EntireRow.Copy .Range("A" & DerCel2)  
            .Range(.Cells(DerCel2, 2), .Cells(DerCel2, .Columns.Count).End(xlToLeft)).Interior.ColorIndex = 3  
        End With  
    ElseIf Cells(Ligne, 10) = 2 Then  
        Ligne2 = Cells(Ligne, 11)  
        With Worksheets("Feuil2")  
            .Range(.Cells(Ligne2, 2), .Cells(Ligne2, .Columns.Count).End(xlToLeft)).Interior.ColorIndex = 6  
        End With  
    End If  
Next Ligne  
End Sub

A tester....   
   
Cordialement,

Définir une plage de feuille VBA

9 réponses

Votre réponse

Discussions similaires

Newsletters