Option Explicit
Dim Te(1 To 500) As String, Le As Long
Sub Ajouter(ByVal Z As String)
Le = Le + 1: Te(Le) = Z
End Sub
Function RésultatCellClassé() As String
Dim Ts() As String, Ls&
ReDim Ts(0 To Le - 1): Ls = -1
With New TableIndex
.Init 1, Le: While .Actif: .BInfA = Te(.B) < Te(.A): Wend
.Parcourir: While .Actif: Le = .Suivant: Ls = Ls + 1: Ts(Ls) = Te(Le): Wend: End With
RésultatCellClassé = Join(Ts, vbLf)
Le = 0
End Function
For Each Cel In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
MemoPos = 1000
For Each c In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
Position = InStr(Cel, c)
If Position > 0 Then
If Cel.Offset(0, 2) <> "" And InStr(Cel.Offset(0, 2), c.Offset(0, 1)) = 0 Then
' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
If Position < MemoPos Then
MemoPos = Position
Cel.Offset(0, 2) = c.Offset(0, 1) & Chr(10) & Cel.Offset(0, 2)
Else
Cel.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & c.Offset(0, 1)
End If
Else
Cel.Offset(0, 2) = c.Offset(0, 1)
MemoPos = Position
End If
End If
Next c
Next Cel
Set WsC = Nothing: Set WsS = Nothing
C'est très simple: vous les enlevez tous au milieu, dans les boucles, et vous n'en laissez qu'au début et à la fin. Et dans les boucles vous accédez uniquement, à la vitesse de la lumière, aux éléments de tableaux, les uns en entrée (ceux initialisés par les Range du début) d'autre en sortie (ceux à destination des Range de fin)Par contrepour optimier mes Ranges comme vous le dites je ne vois pas où puis je les enlever d'ici
Sub Test()
Application.ScreenUpdating = False
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range, c As Range
Dim Position As Integer, MemoPos As Integer
Set WsS = Worksheets("Workon")
Set WsC = Worksheets("Data-Deviations")
Sheets("Data-Deviations").Activate
Range("AI2:AI1000000").ClearContents
For Each Cel In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
MemoPos = 1000
For Each c In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
Position = InStr(Cel, c)
If Position > 0 Then
If Cel.Offset(0, 2) <> "" And InStr(Cel.Offset(0, 2), c.Offset(0, 1)) = 0 Then
' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
If Position < MemoPos Then
MemoPos = Position
Cel.Offset(0, 2) = c.Offset(0, 1) & Chr(10) & Cel.Offset(0, 2)
Else
Cel.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & c.Offset(0, 1)
End If
Else
Cel.Offset(0, 2) = c.Offset(0, 1)
MemoPos = Position
End If
End If
Next c
Next Cel
Set WsC = Nothing: Set WsS = Nothing
Application.ScreenUpdating = True
End Sub
Sub Test()
Application.ScreenUpdating = False
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range, c As Range
Dim Position As Integer, MemoPos As Integer
Set WsS = Worksheets("Workon")
Set WsC = Worksheets("Data-Deviations")
Dim Te As PlageEntrée.Value
Dim Ts As PlageSortie.Value
'Te = PlageEntrée.Value et un autre à la fin: PlageSortie.Value = Ts
Sheets("Data-Deviations").Activate
Range("AI2:AI1000000").ClearContents
For Each Te In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
MemoPos = 1000
For Each Ts In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
Position = InStr(Te, Ts)
If Position > 0 Then
If Te.Offset(0, 2) <> "" And InStr(Te.Offset(0, 2), Ts.Offset(0, 1)) = 0 Then
' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
If Position < MemoPos Then
MemoPos = Position
Te.Offset(0, 2) = Ts.Offset(0, 1) & Chr(10) & Te.Offset(0, 2)
Else
Te.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & Ts.Offset(0, 1)
End If
Else
Te.Offset(0, 2) = Ts.Offset(0, 1)
MemoPos = Position
End If
End If
Next Ts
Next Te
Set WsC = Nothing: Set WsS = Nothing
Application.ScreenUpdating = True
End Sub
Bonjour,
Exemple en PJ
JB
Sub Test()
Application.ScreenUpdating = False
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range, c As Range
Dim Position As Integer, MemoPos As Integer
Set WsS = Worksheets("Workon")
Set WsC = Worksheets("Data-Deviations")
Sheets("Data-Deviations").Activate
Range("AI2:AI1000000").ClearContents
For Each Cel In WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row)
MemoPos = 1000
For Each c In WsS.Range("S2:S" & WsS.Range("S" & Rows.Count).End(xlUp).Row)
Position = InStr(Cel, c)
If Position > 0 Then
If Cel.Offset(0, 2) <> "" And InStr(Cel.Offset(0, 2), c.Offset(0, 1)) = 0 Then
' ligne And InStr(Cel.Offset(0, 2), C.Offset(0, 1)) = 0 supprime doublon
If Position < MemoPos Then
MemoPos = Position
Cel.Offset(0, 2) = c.Offset(0, 1) & Chr(10) & Cel.Offset(0, 2)
Else
Cel.Offset(0, 2) = Cel.Offset(0, 2) & Chr(10) & c.Offset(0, 1)
End If
Else
Cel.Offset(0, 2) = c.Offset(0, 1)
MemoPos = Position
End If
End If
Next c
Next Cel
Set WsC = Nothing: Set WsS = Nothing
Application.ScreenUpdating = True
End Sub
TDévia = WsC.Range("AG2:AH" & WsC.Range("AG" & Rows.Count).End(xlUp).Row).Value
TWorkon = WsC.Range("AG2:AG" & WsC.Range("AG" & Rows.Count).End(xlUp).Row).Value
For Ld = 1 To UBound(TDévia)
mempos = 1000
For Lw = 1 To UBound(TWorkon)
Position = InStr(TDévia(Ld, 1), TWorkon(Lw, 1))
If Position > 0 Then
etc.
Function RésultatCellClassé() As String
Dim Ts() As String, Ls&, Texte As String
ReDim Ts(0 To Le - 1): Ls = -1
With New TableIndex
.Init 0, Le: While .Actif: .BInfA = Te(.B) < Te(.A): Wend
Texte = ""
.Parcourir: While .Actif: Le = .Suivant
If Te(Le) <> Texte Then Texte = Te(Le): Ls = Ls + 1: Ts(Ls) = Texte
Wend: End With
ReDim Preserve Ts(0 To Ls)
RésultatCellClassé = Join(Ts, vbLf)
Le = 0
End Function