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 Sub
Merci 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.count
Donc 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 Sub
Bonjour 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