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