mocro feuille et module bloque

Neptune64 · 11 Septembre 2009

Bonjour le forum,

Quelqu'un pourrait-il m'aider, ci-dessous j'ai 2 macros, la première dans un module et la seconde dans une feuille.
Quand je lance la macro "compare", ça prend un peu de temps avant de démarer, mais ça marche. Mais quand j'ajoute la macro dans la feuille et que je lance le "compare", le document reste bloquer !! possible qu'il s'exécuterais mais cela prend beaucoup trop de temps !!
Et jai besoin des 2 !!

merci de votre aide

Option Explicit

Public bArret As Boolean

Public Sub Compare()
Dim I, col, c, d, e, f As Integer
Dim P, NbNewData, NbDataControle As Long
Dim ValeurCherchee, NomUser As String
Dim ValeurCellule, Retour, PlageCopie, Plage As Range
Dim NbNewCase, NbLigneDecompte, NbLigneArchive, NbNouveauxCas, NbCasTraite As Long
Dim NbAvecSucces, Nbjour7, NumLigneDansNC As Long
Dim Tableau() As String

NbNewData = Sheets("New Data").Cells(65536, 1).End(xlUp).Row
NbDataControle = Sheets("Data controle").Cells(65536, 1).End(xlUp).Row
NbLigneDecompte = Sheets("Decompte").Cells(65536, 1).End(xlUp).Row
NbLigneArchive = Sheets("Archive").Cells(65536, 1).End(xlUp).Row
NbNewCase = Sheets("New Case").Cells(65536, 1).End(xlUp).Row

'Initialisation
NbNouveauxCas = 0: NbCasTraite = 0: NbNewCase = 0:
Nbjour7 = 0

'Efface le contenu de la feuille New Case avant le nouveau transfert
With Sheets("New Case")
If .[A4] <> "" Then
.Range("A4:K" & .Cells(65536, 1).End(xlUp).Row).ClearContents
End If
End With

'Derniere ligne vide dans la feuille New Case
NumLigneDansNC = 4

'----PHASE 1 regarde si nouvelle valeur----
For Each ValeurCellule In Sheets("New Data").Range("A4:A" & NbNewData)
I = ValeurCellule.Row
ValeurCherchee = ValeurCellule.Value
Set Retour = Sheets("Data controle").Range("A4:A" & NbDataControle).Find(ValeurCherchee)

'Si "Retour" est différent de nothing c'est que la valeurcherchee est trouvée donc existe déjà
'on ne fait rien
'on met à jour le nb de jours dans la feuille Data Controle
If Not Retour Is Nothing Then
Sheets("Data controle").Cells(Retour.Row, 2) = Sheets("New Data").Cells(I, 2)
Sheets("Data controle").Cells(Retour.Row, 3) = Sheets("New Data").Cells(I, 3)
Sheets("Data controle").Cells(Retour.Row, 4) = Sheets("New Data").Cells(I, 4)
Sheets("Data controle").Cells(Retour.Row, 5) = Sheets("New Data").Cells(I, 5)

'Sinon "Retour" = nothing c'est que nous avons une nouvelle valeur à insérer
'Si autre type de ligne = transfert vers feuilles
Else
'----TRANSFERT VERS DATA CONTROLE----
For col = 1 To 10
'Arrete la procèdure Worksheet_Change de la feuille Data Controle
bArret = True
Sheets("Data controle").Cells(NbDataControle + 1, col) = Sheets("New Data").Cells(I, col)
Next col

NbNouveauxCas = NbNouveauxCas + 1
'Ajoute une nouvelle valeur insérée dans Data Controle
NbDataControle = NbDataControle + 1

'----TRANSFERT VERS NEW CASE----
For col = 1 To 10
Sheets("New Case").Cells(NumLigneDansNC, 1) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
Sheets("New Case").Cells(NumLigneDansNC, col + 1) = Sheets("New Data").Cells(I, col)
Next col
'Incrémente la ligne d'après
NumLigneDansNC = NumLigneDansNC + 1
End If

Next ValeurCellule

'Suppression des lignes contenues dans la variable Tableau
'avant la phase 2
On Error Resume Next
For I = UBound(Tableau) To 0 Step -1
Sheets("New Data").Cells(Tableau(I), 1).EntireRow.Delete
Next I

'Efface la variable tableau de la mémoire
Erase Tableau

'----PHASE 2 Mise à jour de la liste dans Data Controle----
For Each ValeurCellule In Sheets("Data controle").Range("A4:A" & NbDataControle)
I = ValeurCellule.Row
ValeurCherchee = ValeurCellule.Value
Set Retour = Sheets("New Data").Range("A4:A" & NbNewData).Find(ValeurCherchee)

'Si une valeur dans la variable "Retour" c'est qu'elle existe dans la feuille New Data
'Donc pas de suppression
If Not Retour Is Nothing Then
Else
'Inscription de la date du jour dans l'archive
Sheets("Archive").Cells(NbLigneArchive + 1, 1) = Date
'Recopie des doublons dans l'archive
Set PlageCopie = Sheets("Data controle").Range(Cells(I, 1), Cells(I, 17))
PlageCopie.Copy
Sheets("Archive").Range("b" & NbLigneArchive + 1).PasteSpecial
NbLigneArchive = NbLigneArchive + 1
NbCasTraite = NbCasTraite + 1

'Mémorisation des lignes à supprimer
ReDim Preserve Tableau(NbCasTraite - 1)
Tableau(NbCasTraite - 1) = I
End If
Next ValeurCellule

'Suppression des lignes contenues dans la variable Tableau
On Error Resume Next
For I = UBound(Tableau) To 0 Step -1
Sheets("Data controle").Cells(Tableau(I), 1).EntireRow.Delete
Next I

'Efface la variable tableau de la mémoire
Erase Tableau

'Inscription dans la feuille Decompte
Sheets("Decompte").Cells(NbLigneDecompte + 1, 1) = Application.UserName 'NomUser
Sheets("Decompte").Cells(NbLigneDecompte + 1, 2) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
Sheets("Decompte").Cells(NbLigneDecompte + 1, 5) = NbNouveauxCas
Sheets("Decompte").Cells(NbLigneDecompte + 1, 6) = NbCasTraite
'Fin d'arrêt du blocage de la procèdure
bArret = False

End Sub

Macro sous la feuille !!

Private Sub Worksheet_Change(ByVal Target As Range)

' met de la couleur si la cellule déroulante a changée de valeur

Dim I As Integer 'ligne
Dim Nbmaxlignes As Integer

Dim celltocolor As String ' pour stocker le range à colorier
Dim celltocolor2 As String

Dim celltest As String ' pour test si changement dans cellule
Dim valcol As String

Nbmaxlignes = 1000 'indiquer une ligne de plus que la colonne où il y a le dernier texte

I = 1

Do While I < Nbmaxlignes

valcol = "K"

celltest = valcol & I

celltocolor = "B" & I & ":C" & I
celltocolor2 = "K" & I & ":K" & I

' Range(celltest).Font.Color = RGB(206, 16, 57)
' Range(celltocolor).Interior.ColorIndex = 6

If Range(celltest) = "" Then
Range(celltocolor).Interior.Color = RGB(255, 255, 255)
Range(celltocolor2).Interior.Color = RGB(255, 255, 255)
Else
End If
'
If Range(celltest) = "Not installed" Then 'Orange 1
Range(celltocolor).Interior.Color = RGB(255, 165, 0)
Range(celltocolor2).Interior.Color = RGB(255, 165, 0)
Else
End If
'
If Range(celltest) = "Wait answer client" Then 'Pink 2
Range(celltocolor).Interior.Color = RGB(255, 105, 180)
Range(celltocolor2).Interior.Color = RGB(255, 105, 180)
Else
End If
'
If Range(celltest) = "Task open" Then 'bleu 3
Range(celltocolor).Interior.Color = RGB(135, 206, 250)
Range(celltocolor2).Interior.Color = RGB(135, 206, 250)
Else
End If
'
If Range(celltest) = "Reminder" Then 'Gris 4
Range(celltocolor).Interior.Color = RGB(190, 190, 190)
Range(celltocolor2).Interior.Color = RGB(190, 190, 190)
Else
End If
'
If Range(celltest) = "Devices ?" Then 'jaune clair 5
Range(celltocolor).Interior.Color = RGB(255, 255, 0)
Range(celltocolor2).Interior.Color = RGB(255, 255, 0)
Else
End If
'
If Range(celltest) = "Bloked finance" Then 'violet 6
Range(celltocolor).Interior.Color = RGB(186, 85, 211)
Range(celltocolor2).Interior.Color = RGB(186, 85, 211)
Else
End If
'
If Range(celltest) = "RMA devices" Then 'Pink foncé 7
Range(celltocolor).Interior.Color = RGB(255, 0, 255)
Range(celltocolor2).Interior.Color = RGB(255, 0, 255)
Else
End If
'
If Range(celltest) = "Connected" Then 'vert clair 8
Range(celltocolor).Interior.Color = RGB(0, 255, 0)
Range(celltocolor2).Interior.Color = RGB(0, 255, 0)
Else
End If
'

I = I + 1

Loop

End Sub

Compte Supprimé 979 · 11 Septembre 2009

Re : mocro feuille et module bloque

Salut Neptune64,

Franchement un fichier avec tes codes serait mieux venu !

Plutôt qu'un long fil comme celui là que de plus n'a pas les balises début/fin CODE

Pour moi le problème vient du fait que tu as un évènement : Worksheet_Change
donc à chaque modification aportée, l'évènement est exécuté !

A+

soenda · 12 Septembre 2009

Re : mocro feuille et module bloque

Bonsoir le fil, Neptune64, Salut Bruno

De plus, dans les déclarations

Code:

Public Sub Compare()
Dim [COLOR=red][B]I[/B][/COLOR], [COLOR=red][B]col[/B][/COLOR], [COLOR=red][B]c[/B][/COLOR], [COLOR=red][B]d[/B][/COLOR], [B][COLOR=red]e[/COLOR][/B], f As Integer
Dim [B][COLOR=red]P[/COLOR][/B], [B][COLOR=red]NbNewData[/COLOR][/B], NbDataControle As Long
Dim [COLOR=red][B]ValeurCherchee[/B][/COLOR], NomUser As String
 ...

toutes les variables en rouge sont des "Variant".
Et ça, ça ne peut pas accélérer ton code.

Pour rester concis tout en typant les variables ;

Code:

Public Sub Compare()
Dim I[COLOR=blue][B]%[/B][/COLOR], col[COLOR=blue][B]%[/B][/COLOR], c[COLOR=blue][B]%[/B][/COLOR], d[COLOR=blue][B]%[/B][/COLOR], e[COLOR=blue][B]%[/B][/COLOR], f As Integer
Dim P[COLOR=blue][B]&[/B][/COLOR], NbNewData[COLOR=blue][B]&[/B][/COLOR], NbDataControle As Long
Dim ValeurCherchee[B][COLOR=blue]$[/COLOR][/B], NomUser As String
 ...

A plus

sudistsa · 12 Septembre 2009

Re : mocro feuille et module bloque

Vous n'êtes pas connecté

Neptune64 · 13 Septembre 2009

Re : La macro de la feuille ralenti celle du module

Bonjour à tous,
Oui désolé je ne conaissais pas pour le code !!

Alors voilà je vais ajouté le code avec les balise !!
Pour les déclaration j'ai changé mais ce n'est pas plus rapide

j'ai simplifié le code de la feuille, je pense que c'est mieux comme ça

le code ci-dessous est dans la feuille parce que selon le mot que je change dans ma feuille je dois changer la couleur dans certaines cellules. Mais il y a peut-être une autre possibilité, je ne connais pas !!

Ce que je ne comprend pas c'est que quand je n'ai pas ce code dans la feuille, ma macro prend 10 x moins de temps pour s'exécuter ?

A part le problème de temps ça fonctionne très bien !!

Merci

))))

Code de la feuille

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim i As Integer 'ligne
 
For i = Cells(4, 11).CurrentRegion.Rows.Count To 1 Step -1
If Cells(i, 11).Value = "" Then Cells(i, 11).Interior.Color = RGB(255, 255, 255)
If Cells(i, 11).Value = "" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 255, 255)
 
If Cells(i, 11).Value = "Not installed" Then Cells(i, 11).Interior.Color = RGB(255, 165, 0) 'Orange 1
If Cells(i, 11).Value = "Not installed" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 165, 0) 'Orange 1
 
If Cells(i, 11).Value = "Wait answer client" Then Cells(i, 11).Interior.Color = RGB(255, 105, 180) 'Pink 2
If Cells(i, 11).Value = "Wait answer client" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 105, 180) 'Pink 2
 
If Cells(i, 11).Value = "Task open" Then Cells(i, 11).Interior.Color = RGB(135, 206, 250) 'bleu 2
If Cells(i, 11).Value = "Task open" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(135, 206, 250) 'bleu 2
 
If Cells(i, 11).Value = "Reminder" Then Cells(i, 11).Interior.Color = RGB(190, 190, 190) 'gris 4
If Cells(i, 11).Value = "Reminder" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(190, 190, 190) 'gris 4
 
If Cells(i, 11).Value = "Devices ?" Then Cells(i, 11).Interior.Color = RGB(255, 255, 0) 'jaune clair 5
If Cells(i, 11).Value = "Devices ?" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 255, 0) 'jaune clair 5
 
If Cells(i, 11).Value = "Bloked finance" Then Cells(i, 11).Interior.Color = RGB(186, 85, 211) 'violet 6
If Cells(i, 11).Value = "Bloked finance" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(186, 85, 211) 'violet 6
 
If Cells(i, 11).Value = "RMA devices" Then Cells(i, 11).Interior.Color = RGB(255, 0, 255) 'Pink foncé 7
If Cells(i, 11).Value = "RMA devices" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(255, 0, 255) 'Pink foncé 7
 
If Cells(i, 11).Value = "Connected" Then Cells(i, 11).Interior.Color = RGB(0, 255, 0) 'vert clair 8
If Cells(i, 11).Value = "Connected" Then Range(Cells(i, 2), Cells(i, 3)).Interior.Color = RGB(0, 255, 0) 'vert clair 8
Next i
 
End

macro du module qui check les modifications entre 2 feuilles et déplace les données

Code:

Option Explicit

Public bArret As Boolean

Public Sub Compare()

    Dim i%, col%, c%, d%, e%, f As Integer
    Dim P&, NbNewData&, NbDataControle As Long
    Dim ValeurCherchee$, NomUser As String
    Dim ValeurCellule, Retour, PlageCopie, Plage As Range
    Dim NbNewCase, NbLigneDecompte, NbLigneArchive, NbNouveauxCas, NbCasTraite As Long
    Dim NbAvecSucces, Nbjour7, NumLigneDansNC As Long
    Dim Tableau() As String
    
NbNewData = Sheets("New Data").Cells(65536, 1).End(xlUp).Row
NbDataControle = Sheets("Data controle").Cells(65536, 1).End(xlUp).Row
NbLigneDecompte = Sheets("Decompte").Cells(65536, 1).End(xlUp).Row
NbLigneArchive = Sheets("Archive").Cells(65536, 1).End(xlUp).Row
NbNewCase = Sheets("New Case").Cells(65536, 1).End(xlUp).Row


'Initialisation
NbNouveauxCas = 0: NbCasTraite = 0: NbNewCase = 0:
Nbjour7 = 0

'Efface le contenu de la feuille New Case avant le nouveau transfert
With Sheets("New Case")
    If .[A4] <> "" Then
        .Range("A4:K" & .Cells(65536, 1).End(xlUp).Row).ClearContents
    End If
End With

'Derniere ligne vide dans la feuille New Case
NumLigneDansNC = 4


'----PHASE 1 regarde si nouvelle valeur----
For Each ValeurCellule In Sheets("New Data").Range("A4:A" & NbNewData)
    i = ValeurCellule.Row
    ValeurCherchee = ValeurCellule.Value
    Set Retour = Sheets("Data controle").Range("A4:A" & NbDataControle).Find(ValeurCherchee)
    
    'Si "Retour" est différent de nothing c'est que la valeurcherchee est trouvée donc existe déjà
    'on ne fait rien
    'on met à jour le nb de jours dans la feuille Data Controle
    If Not Retour Is Nothing Then
        Sheets("Data controle").Cells(Retour.Row, 2) = Sheets("New Data").Cells(i, 2)
        Sheets("Data controle").Cells(Retour.Row, 3) = Sheets("New Data").Cells(i, 3)
        Sheets("Data controle").Cells(Retour.Row, 4) = Sheets("New Data").Cells(i, 4)
        Sheets("Data controle").Cells(Retour.Row, 5) = Sheets("New Data").Cells(i, 5)
        
    'Sinon "Retour" = nothing c'est que nous avons une nouvelle valeur à insérer
    'Si autre type de ligne = transfert vers feuilles
    Else
        '----TRANSFERT VERS DATA CONTROLE----
        For col = 1 To 10
            'Arrete la procèdure Worksheet_Change de la feuille Data Controle
            bArret = True
            Sheets("Data controle").Cells(NbDataControle + 1, col) = Sheets("New Data").Cells(i, col)
        Next col
        
        NbNouveauxCas = NbNouveauxCas + 1
        'Ajoute une nouvelle valeur insérée dans Data Controle
        NbDataControle = NbDataControle + 1
        
        '----TRANSFERT VERS NEW CASE----
        For col = 1 To 10
            Sheets("New Case").Cells(NumLigneDansNC, 1) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
            Sheets("New Case").Cells(NumLigneDansNC, col + 1) = Sheets("New Data").Cells(i, col)
        Next col
        'Incrémente la ligne d'après
        NumLigneDansNC = NumLigneDansNC + 1
     End If
     
Next ValeurCellule
       
'Suppression des lignes contenues dans la variable Tableau
'avant la phase 2
On Error Resume Next
For i = UBound(Tableau) To 0 Step -1
    Sheets("New Data").Cells(Tableau(i), 1).EntireRow.Delete
Next i

'Efface la variable tableau de la mémoire
Erase Tableau

'----PHASE 2 Mise à jour de la liste dans Data Controle----
For Each ValeurCellule In Sheets("Data controle").Range("A4:A" & NbDataControle)
    i = ValeurCellule.Row
    ValeurCherchee = ValeurCellule.Value
    Set Retour = Sheets("New Data").Range("A4:A" & NbNewData).Find(ValeurCherchee)
    
    'Si une valeur dans la variable "Retour" c'est qu'elle existe dans la feuille New Data
    'Donc pas de suppression
    If Not Retour Is Nothing Then
    Else
        'Inscription de la date du jour dans l'archive
        Sheets("Archive").Cells(NbLigneArchive + 1, 1) = Date
        'Recopie des doublons dans l'archive
        Set PlageCopie = Sheets("Data controle").Range(Cells(i, 1), Cells(i, 17))
        PlageCopie.Copy
        Sheets("Archive").Range("b" & NbLigneArchive + 1).PasteSpecial
        NbLigneArchive = NbLigneArchive + 1
        NbCasTraite = NbCasTraite + 1
        
        'Mémorisation des lignes à supprimer
        ReDim Preserve Tableau(NbCasTraite - 1)
        Tableau(NbCasTraite - 1) = i
    End If
Next ValeurCellule

'Suppression des lignes contenues dans la variable Tableau
On Error Resume Next
For i = UBound(Tableau) To 0 Step -1
    Sheets("Data controle").Cells(Tableau(i), 1).EntireRow.Delete
Next i

'Efface la variable tableau de la mémoire
Erase Tableau

'Inscription dans la feuille Decompte
Sheets("Decompte").Cells(NbLigneDecompte + 1, 1) = Application.UserName 'NomUser
Sheets("Decompte").Cells(NbLigneDecompte + 1, 2) = Format(Date, "dd.mm.yyyy ") & Format(Time, "hh") & " h " & Format(Time, "mm")
Sheets("Decompte").Cells(NbLigneDecompte + 1, 5) = NbNouveauxCas
Sheets("Decompte").Cells(NbLigneDecompte + 1, 6) = NbCasTraite
'Fin d'arrêt du blocage de la procèdure
bArret = False

End Sub

Neptune64 · 14 Septembre 2009

Re : mocro feuille et module bloque

Hello !!

J'ai trouvé une solution c'est d'ajouter

Code:

Public Sub Compare()
Application.EnableEvents = False
 
'...
 
Application.EnableEvents = True
End Sub

à ma macro et ça marche !!

Cool

Effectuez une recherche sur Excel Downloads...

mocro feuille et module bloque

Neptune64

XLDnaute Nouveau

Compte Supprimé 979

Guest

soenda

XLDnaute Accro

sudistsa

XLDnaute Nouveau

Neptune64

XLDnaute Nouveau

Neptune64

XLDnaute Nouveau

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums