Message box avec le nbr de ligne transferer
Bonjour ,
Je souhaiterai améliorée une macro , pour cela il faudrait que j'insère un message box me donnant le nombre de ligne transférer.
Auriez-vous une idée , à conseillée, à me communiquée ? , je ne ses pas pas ou commencée ni ou l'insérer dans ma macro .
Voici le code
Sub Transfert_LLS_Suivi()
Dim Dlig As Long, Lig As Long, nLig As Long
Dim ShtS As Worksheet, ShtD As Worksheet
Dim Dico As Object, sKey As String
' Définir les feuilles
Set ShtS = ThisWorkbook.Sheets("LLS")
Set ShtD = ThisWorkbook.Sheets("SUIVI")
' Dernière ligne remplie de la feuille source
Dlig = ShtS.Range("A" & Rows.Count).End(xlUp).Row
' Nouvelles ligne de la feuille de destination
nLig = ShtD.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row
' Définir le dictionnaire pour les doublons et le remplir
Set Dico = CreateObject("Scripting.Dictionary")
With ShtD
For Lig = 2 To nLig - 1
sKey = .Range("O" & Lig).Value
Dico(sKey) = ""
Next Lig
End With
With ShtS
For Lig = 2 To Dlig
If .Rows(Lig).Hidden = False Then
sKey = .Range("N" & Lig).Value
' Si clé n'existe pas
If Not Dico.Exists(sKey) Then
' L'ajouter
Dico.Add sKey, ""
' Copier les données
ShtD.Range("B" & nLig).Value = ShtS.Range("A" & Lig).Value
ShtD.Range("C" & nLig).Value = ShtS.Range("C" & Lig).Value
ShtD.Range("D" & nLig).Value = ShtS.Range("B" & Lig).Value
ShtD.Range("E" & nLig).Value = ShtS.Range("D" & Lig).Value
ShtD.Range("F" & nLig).Value = ShtS.Range("E" & Lig).Value
ShtD.Range("G" & nLig).Value = ShtS.Range("I" & Lig).Value
ShtD.Range("H" & nLig).Value = ShtS.Range("J" & Lig).Value
' Incrémenter les nouvelle lignes
nLig = nLig + 1
End If
End If
Next Lig
End With
Set ShtD = Nothing: Set ShtS = Nothing
'message box de confirmation
MsgBox "Transfert OK !", vbInformation, "Terminée !"
End SubMerci d'avance
Bonne journée
Cordialement
Je pense qu'il faut faire un CALCULATE sur le dico des doublons ?
Hello,
Pour compter le nombre d'éléments dans un dico c'est :
Dico.countDonc peut être comme ceci :
Sub Transfert_LLS_Suivi()
Dim Dlig As Long, Lig As Long, nLig As Long
Dim ShtS As Worksheet, ShtD As Worksheet
Dim Dico As Object, sKey As String
' Définir les feuilles
Set ShtS = ThisWorkbook.Sheets("LLS")
Set ShtD = ThisWorkbook.Sheets("SUIVI")
' Dernière ligne remplie de la feuille source
Dlig = ShtS.Range("A" & Rows.Count).End(xlUp).Row
' Nouvelles ligne de la feuille de destination
nLig = ShtD.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row
' Définir le dictionnaire pour les doublons et le remplir
Set Dico = CreateObject("Scripting.Dictionary")
With ShtD
For Lig = 2 To nLig - 1
sKey = .Range("O" & Lig).Value
Dico(sKey) = ""
Next Lig
End With
With ShtS
For Lig = 2 To Dlig
If .Rows(Lig).Hidden = False Then
sKey = .Range("N" & Lig).Value
' Si clé n'existe pas
If Not Dico.Exists(sKey) Then
' L'ajouter
Dico.Add sKey, ""
' Copier les données
ShtD.Range("B" & nLig).Value = ShtS.Range("A" & Lig).Value
ShtD.Range("C" & nLig).Value = ShtS.Range("C" & Lig).Value
ShtD.Range("D" & nLig).Value = ShtS.Range("B" & Lig).Value
ShtD.Range("E" & nLig).Value = ShtS.Range("D" & Lig).Value
ShtD.Range("F" & nLig).Value = ShtS.Range("E" & Lig).Value
ShtD.Range("G" & nLig).Value = ShtS.Range("I" & Lig).Value
ShtD.Range("H" & nLig).Value = ShtS.Range("J" & Lig).Value
' Incrémenter les nouvelle lignes
nLig = nLig + 1
End If
End If
Next Lig
End With
Set ShtD = Nothing: Set ShtS = Nothing
'message box de confirmation
MsgBox "Transfert OK ! " & Dico.count & " transferts effectués.", vbInformation, "Terminée !"
End SubBonjour Rag,
Merci pour ton retour ,
Effectivement je ne connaissait pas cette fonction . Mais elle me dépanne bien pour ma problématique .
En recherchant un peu j'ai trouver le COMPARE ou DICO INVERSE ? pense tu que je peut le traduire on disant je compte le nombre de ligne qui étai non présente avant le transfert = non présent dans le dico
Merci encore
Bonne journée
Hello,
Je comprends pas trop ce que tu cherches à faire ... dsl
Tu peux être un peu + clair stp