Private Sub Worksheet_Activate()
Dim ncol%, tablo, resu(), d As Object, i&, x$, n&, j%, a
ncol = 3 'nombre de colonnes, à adapter
'---liste sans doublon---
tablo = Sheets("Saisie").[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
d(CStr(tablo(i, 1))) = ""
Next i
'---tableau des résultats---
If d.Count Then
ReDim resu(1 To Rows.Count, 1 To ncol)
tablo = [A1].CurrentRegion.Resize(, 3).Formula 'pour conserver les formules
For i = 1 To UBound(tablo)
x = tablo(i, 1)
If Left(x, 1) = "=" Then x = CStr(Evaluate(x)) 's'il y a une formule en colonne A elle est conservée
If d.exists(x) Then
n = n + 1
For j = 1 To ncol
resu(n, j) = tablo(i, j) 'copie la ligne
Next j
d.Remove x 'l'élément traité est retiré de la liste
End If
Next i
End If
'---ajout des éléments de la liste non traités---
If d.Count Then
a = d.keys
For i = 0 To UBound(a)
n = n + 1
resu(n, 1) = a(i)
Next i
End If
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
If n Then
.Resize(n, ncol) = resu
.Resize(n, ncol).Sort .Cells, xlAscending, Header:=xlNo 'tri sur la 1ère colonne
End If
.Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Bonjour GOLE, sylvanu, _Thierry,
Voyez le fichier joint et cette macro dans le code de la 2ème feuille :
La macro se déclenche quand on active la feuille.VB:Private Sub Worksheet_Activate() Dim ncol%, tablo, resu(), d As Object, i&, x$, n&, j%, a ncol = 3 'nombre de colonnes, à adapter '---liste sans doublon--- tablo = Sheets("Saisie").[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments Set d = CreateObject("Scripting.Dictionary") For i = 2 To UBound(tablo) d(CStr(tablo(i, 1))) = "" Next i '---tableau des résultats--- If d.Count Then ReDim resu(1 To Rows.Count, 1 To ncol) tablo = [A1].CurrentRegion.Resize(, 3).Formula 'pour conserver les formules For i = 1 To UBound(tablo) x = tablo(i, 1) If Left(x, 1) = "=" Then x = CStr(Evaluate(x)) 's'il y a une formule en colonne A elle est conservée If d.exists(x) Then n = n + 1 For j = 1 To ncol resu(n, j) = tablo(i, j) 'copie la ligne Next j d.Remove x 'l'élément traité est retiré de la liste End If Next i End If '---ajout des éléments de la liste non traités--- If d.Count Then a = d.keys For i = 0 To UBound(a) n = n + 1 resu(n, 1) = a(i) Next i End If '---restitution--- Application.ScreenUpdating = False If FilterMode Then ShowAllData 'si la feuille est filtrée With [A2] '1ère cellule de destination, à adapter If n Then .Resize(n, ncol) = resu .Resize(n, ncol).Sort .Cells, xlAscending, Header:=xlNo 'tri sur la 1ère colonne End If .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents 'RAZ en dessous End With With UsedRange: End With 'actualise la barre de défilement verticale End Sub
Avec cette solution la colonne C de la 1ère feuille est inutile.
Les formules de la 2ème feuille sont conservées.
A+
Bonjour GOLE, sylvanu, _Thierry,
Voyez le fichier joint et cette macro dans le code de la 2ème feuille :
La macro se déclenche quand on active la feuille.VB:Private Sub Worksheet_Activate() Dim ncol%, tablo, resu(), d As Object, i&, x$, n&, j%, a ncol = 3 'nombre de colonnes, à adapter '---liste sans doublon--- tablo = Sheets("Saisie").[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments Set d = CreateObject("Scripting.Dictionary") For i = 2 To UBound(tablo) d(CStr(tablo(i, 1))) = "" Next i '---tableau des résultats--- If d.Count Then ReDim resu(1 To Rows.Count, 1 To ncol) tablo = [A1].CurrentRegion.Resize(, 3).Formula 'pour conserver les formules For i = 1 To UBound(tablo) x = tablo(i, 1) If Left(x, 1) = "=" Then x = CStr(Evaluate(x)) 's'il y a une formule en colonne A elle est conservée If d.exists(x) Then n = n + 1 For j = 1 To ncol resu(n, j) = tablo(i, j) 'copie la ligne Next j d.Remove x 'l'élément traité est retiré de la liste End If Next i End If '---ajout des éléments de la liste non traités--- If d.Count Then a = d.keys For i = 0 To UBound(a) n = n + 1 resu(n, 1) = a(i) Next i End If '---restitution--- Application.ScreenUpdating = False If FilterMode Then ShowAllData 'si la feuille est filtrée With [A2] '1ère cellule de destination, à adapter If n Then .Resize(n, ncol) = resu .Resize(n, ncol).Sort .Cells, xlAscending, Header:=xlNo 'tri sur la 1ère colonne End If .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents 'RAZ en dessous End With With UsedRange: End With 'actualise la barre de défilement verticale End Sub
Avec cette solution la colonne C de la 1ère feuille est inutile.
Les formules de la 2ème feuille sont conservées.
A+
Bonjour Job75,
Merci d'abord pour ce code de ouf!
Par contre ça ne correspond pas à ce que je veux
Effectivement la colonne C de la feuille saisie est inutile
Dans la feuille table j'ai un tableau à l'origine vierge avec des formules sur certaines colonnes
La dernière réponse de thierry marchait trés bien dans le test mais mon application réelle comporte + de 100 colonnnes et 500 lignes dont 60 colonnes avec des formules
il faudrait juste modifier dans son code la partie ou il duplique les formules de la ligne d'aprés pour les mettre sur la nouvelle ligne référencée j'ai mis dans le commentaire de son codela partie qu'il faudrait modifier commençant par 'Merci job 75...
Vu le niveau que vous avez ça devrait pas être trop dur
Merci pour votre réponse
Private Sub Worksheet_Change(ByVal Target As Range)
With [A1].CurrentRegion.Offset(1)
If .Rows.Count = 1 Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
.Columns(4).Resize(.Rows.Count - 1) = "=B2*100"
.Columns(5).Resize(.Rows.Count - 1) = "=SQRT(D2)"
.Columns(7).Resize(.Rows.Count - 1) = "=E2/2"
Application.EnableEvents = True 'réactive les évènements
End With
Private Sub Worksheet_Change(ByVal Target As Range)
Dim col%
With [A1].CurrentRegion.Offset(1)
If .Rows.Count = 1 Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For col = 1 To .Columns.Count
If Sheets("Formules").Cells(2, col).HasFormula Then _
.Columns(col).Resize(.Rows.Count - 1) = Sheets("Formules").Cells(2, col).Formula
Next
Application.EnableEvents = True 'réactive les évènements
End With
End Sub
'---liste sans doublon---
With Sheets("Saisie")
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
tablo = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)(2)) 'matrice, plus rapide, au moins 2 éléments
End With
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
x = CStr(tablo(i, 1))
If x <> "" Then d(x) = ""
Next i