Remplacement d'une boucle

bonjour

j'ai un petit soucis avec le code ci dessous .

Mon fichier fait plus de 100000 lignes est ma boucle "patine" un peut. Quelqu'un aurait il une solution pour remplacer ma boucle.

merci d'avance pour votre aide.

cordialement

philippe

ci joint le fichier

Sub famille()

 Application.ScreenUpdating = False

Dim ligne As String 

ligne = 2

Do While Cells(ligne, 1).Value <> ""
Cells(ligne, 25).Value = Application.WorksheetFunction.WeekNum(Cells(ligne, 7).Value)
 With Cells(ligne, 27)
 .Formula = "=IFERROR(VLOOKUP(RC[-19],'famille'!C[-27]:C[-26],2,FALSE),"""")"
   .Value = .Value
End With

ligne = ligne + 1
Loop

 Application.ScreenUpdating = True 
MsgBox "traitement terminé"

Bonjour Philippe, bonjour le forum,

Essaie comme ça :

Sub famille2()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TVS As Variant 'déclare la variable TVS (Tableau des Valeurs Source)
Dim TVD As Variant 'déclare la variable TVD (Tableau des Valeurs Destination)
Dim I As Long 'déclare la variable I(Incrément)
Dim J As Long 'déclare la variable J(Incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set OS = Worksheets("famille") 'définit l'onglet OS
Set OD = Worksheets("Feuil1") 'définit l'onglet OD
TVS = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs de l'onglet source TVS
TVD = OD.Range("A1").CurrentRegion 'définit le tableau des valeurs de l'onglet destination TVD
ReDim TL(1 To 3, 1 To UBound(TVD) - 1) 'redimensionne le tableau des lignes TL (3 lignes, 1 colonne en moins que TVD a de lignes, l'en-tête)
For I = 2 To UBound(TVD, 1) 'boucle 1 : sur toutes les lignes I du tableau des valeurs de l'onglet destination TVD (en partant de la seconde)
    TL(1, I - 1) = Application.WorksheetFunction.WeekNum(TVD(I, 7)) 'récupère dans la ligne 1 de TL le numéro de semaine de la donnée ligne I colonne 7 de TVD
    For J = 2 To UBound(TVS, 1) 'boucle 2 : sur toutes les lignes J du tableau des valeurs de l'onglet source TVS (en partant de la seconde)
        If CStr(TVD(I, 8)) = CStr(TVS(J, 1)) Then 'condition : si la donnée ligne I colonne 8 de TVD est égale à la donnée ligne J colonne 1 de TVS
            TL(3, I - 1) = TVS(J, 2) 'récupère dans la ligne 3 de TL la donnée en colonne 2 de TVS
            Exit For 'sort de la boucle 2
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
Next I 'prochaine ligne de la boucle 1
'renvoie dans Y2 redimensionnée le tableau TL transposé
OD.Range("Y2").Resize(UBound(TL, 2), 3).Value = Application.Transpose(TL)
End Sub

Bonjour, Salut ThauThème !

Qu'entends-tu par "patine" ?

1er essai (sans rien changer à la méthode) :

mais plage nommée : colonne Sorte de la feuille famille,

élimination de WeekNum qui ne donne pas le numéro de semaine, au profit d'une fonction qui donne le bon !

création d'une fonction de recherche utilisant la plage nommée :

Function NSem(d As Date) As Integer
    Dim dref
    dref = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 3)
    dref = dref - Weekday(dref) + 2
    NSem = (d - dref) \ 7 + 1
End Function

Function RechFam(srt As String) As String
    Dim i%
    On Error Resume Next
    i = WorksheetFunction.Match(srt, [Sorte], 0)
    If Err.Number = 0 Then
        RechFam = [Sorte].Cells(i, 2)
    Else
        RechFam = ""
    End If
End Function

Sub famille()
    Dim ligne As Long
    ligne = 2
    Application.ScreenUpdating = False
    With Worksheets("Feuil1")
        Do While .Cells(ligne, 1).Value <> ""
            .Cells(ligne, 25).Value = NSem(Int(.Cells(ligne, 7)))
            .Cells(ligne, 27).Value = RechFam(.Cells(ligne, 8).Text)
            ligne = ligne + 1
        Loop
    End With
    MsgBox "traitement terminé"
End Sub

Me dire le temps que ça prend et le cas échéant on changera de méthode...

Cordialement.

edit : J'avais machinalement rectifié ta variable String en Integer, ce qui n'ira manifestement pas pour 100000 lignes !

Je viens de rectifier en Long, de même dans le fichier...

bonjour

si je n'ai pas répondu plus tot , c'est que j'ai eu des petit soucis perso.

je tiens quand même à vous remercier pour votre aide.

cordialement

philippe

Bonne continuation à toi.