Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !
D'expérience je peux vous dire que la fonction Union ne pose pas de problème pour unir quelques centaines de zones disjointes.
Au delà de 1000 zones elle prend beaucoup de temps.
Sub test2()
Dim i&, j&, n&, s, t(), xrg As Range, deb
[a1].Select
deb = Timer
For i = 1 To 200 Step 2
For j = 1 To 39 Step 2
s = s & "," & Cells(i, j).Address(0, 0)
If Len(s) > 240 Then: n = n + 1: ReDim Preserve t(0 To n): t(UBound(t)) = s: s = ""
Next j
Next i
If s <> "" Then ReDim Preserve t(0 To UBound(t) + 1): t(UBound(t)) = s: s = ""
If t(1) <> "" Then Set xrg = Range(Mid(t(1), 2))
n = 0
For i = 2 To UBound(t): n = n + 1: Set xrg = Union(xrg, Range(Mid(t(i), 2))): Next
xrg.Select
MsgBox "Durée exécution avec " & n & " UNION : " & Format(Timer - deb, "#,##0.00\ s")
End Sub
Sub Grouper2()
Dim c As Range, P As Range
On Error Resume Next 'si aucune SpecialCell
For Each c In Cells.SpecialCells(xlCellTypeConstants)
If c <> "" Then Set P = Union(IIf(P Is Nothing, c.MergeArea, P), c.MergeArea)
Next
P.Select
End Sub
For Each c In Cells.SpecialCells(xlCellTypeConstants, 1)
For Each c In Cells.SpecialCells(xlCellTypeConstants, 2)
Private Sub Worksheet_Activate()
Dim c As Range, cc As Range, P As Range, n&
For Each c In Sheets("Listes").[D2:D1000]
If c <> "" Then
Set cc = Cells.Find(c, , xlValues, xlWhole)
If cc Is Nothing Then
MsgBox c & " pas trouvé"
Else
Set P = Union(IIf(P Is Nothing, cc, P), cc)
n = n + 1
End If
End If
Next
If n Then P.Select: MsgBox n & " éléments trouvés"
End Sub
Dans mes premiers essais la macro précédente s'exécutait rapidement.
Maintenant elle met beaucoup de temps, je ne sais pas pourquoi.
Sub Worksheet_Activate()
Dim c, cc, P As Range, n&, k&, s$, dico As Object, t, x
' init
Application.ScreenUpdating = False
s = "Liste des absents:"
' dictionary des références potentielles sur le plan
Set dico = CreateObject("scripting.dictionary")
dico.CompareMode = TextCompare
For Each cc In Sheets("Plan").Range("b2:fv100").Cells
x = Trim(cc.Value)
If x <> "" Then If Len(x) < 7 And x Like "*#" Then dico(x) = cc.Address(0, 0)
Next cc
' P => Union des adresses correspondant à des références trouvées
' s => Liste des références non trouvées
For Each c In [t_Listes].Columns(4).Value
If Trim(c) <> "" Then
If dico.Exists(c) Then
n = n + 1
If n = 1 Then Set P = Range(dico(c)) Else Set P = Union(P, Range(dico(c)))
Else
k = k + 1
s = s & vbLf & c
End If
End If
Next c
' sélection et information
If n Then P.Select Else [a1].Select
ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1
Application.ScreenUpdating = True
MsgBox "Nombre d'éléments présents : " & Format(n, "#,##0") & vbLf & _
"Nombre d'éléments absents : " & Format(k, "#,##0") & vbLf & vbLf & s
End Sub
La macro de @job75 fait la même chose et je m'en suis inspiré. C'est simplement la méthode que j'ai modifiée.Il me reste à tester la macro proposée par Job75
La méthode "Find" n'est pas très rapide mais en plus ici la feuille "Plan" est très tarabiscotée.J'ai testé la macro de Job75... J'ai cru que mon ordi était en panne 😉
De fait, ça rame vraiment dur.
Bonsoir Job75 et bonsoir mapomme,La méthode "Find" n'est pas très rapide mais en plus ici la feuille "Plan" est très tarabiscotée.
Si l'on efface tous ses formats la macro s'exécute chez moi en 1,3 seconde.
We use cookies and similar technologies for the following purposes:
Est ce que vous acceptez les cookies et ces technologies?
We use cookies and similar technologies for the following purposes:
Est ce que vous acceptez les cookies et ces technologies?