Heres a code that update weekly datas from production reports

Known flaws :

  1. Im copy pasting the old line and replacing the week number in it to fit it to the one we want to update. The problem is that its not taking in account if cell emplacement of the data is changing. I also tought it was simpler than re-writing all formulas in every-cell by coding every bits of formula (file emplacement, file name and cell emplacement changes every ranges)
  2. Should i call my action if true in another sub to make this clearer? (ex: if true, call(copy-paste-find-replace)
  3. I have 1 code per sheet (3 sheets) cause of the ranges are hard coded and changes depending on the sheets, with your answer to (1) i could make it a single sub with variables depending on the sheet
  4. I have a week and a half remaining to make this as clean as possible, i dont want to refactor it all the way .. :(

Heres one of the 3 code :

Sub AjoutSemaineajouterperfo()
    ' AjoutSemaineajouterperfo Macro
    ' Le code permet d'ajouter une nouvelle Semaineajouteraine

    Dim k As Long
    k = 3

    Do While (Cells(k, 3).Value <> "" And k <= 53) ' Boucle qui trouve la première ligne Semaineajouteraine vide
        k = k + 1

    k = k - 2                                    ' La boucle while ajoute une Semaine de trop, on veut aussi revenir sur la dernière semaine rentrer (d'ou le -2)

    Dim Semaineajouter As Long
    Dim Destination As Long
    Dim Semaineavant As Long
    Semaineajouter = Cells(59, 3).Value          ' Valeur de la semaine à ajouter(case)
    Destination = Semaineajouter + 1             ' Ligne ou la prochaine semaine va se coller
    Semaineavant = Semaineajouter - 1            ' Ligne de la dernière semaine importer

    Dim semaineactuelle As Long
    semaineactuelle = WorksheetFunction.WeekNum(Now, vbMonday)

    If Semaineajouter > k And Semaineajouter <= 52 And Semaineajouter <> semaineactuelle Then
        ' Si le numéro de Semaineajouteraine entrée est plus grand que la dernière semaine ajouté  et différent de la semaine actuelle
        ' Aussi plus petit que 52 (préserver la mise en forme

        Application.EnableEvents = False
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False

        Dim semaineajoutertex As String
        Dim semaineavanttex As String
        semaineajoutertex = "sem " & CStr(Semaineajouter) ' Transfert des numéros de semaine en texte (pour search and replace)
        semaineavanttex = "sem " & CStr(Semaineavant)
        ' Range 1
        Dim RangeOrigine1 As String
        RangeOrigine1 = "C" & Semaineajouter & ":" & "AX" & Semaineajouter ' Range d'origine (semaine avant)
        Dim RangeDestination1 As String
        RangeDestination1 = "C" & Destination & ":" & "AX" & Destination ' Range à importer (semaine ajout)
        Range(RangeOrigine1).Copy Range(RangeDestination1)
        Range(RangeDestination1).Replace What:=semaineavanttex, Replacement:=semaineajoutertex, LookAt:=xlPart, _
                                         SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.EnableEvents = True
        MsgBox "Entrez un numéro de Semaineajouteraine valide", vbCritical, "Ne peut exécuter"
    End If

End Sub

In window data sample

In this case, pressing GO would call the macro and add week 33 by copy-pasting-find-replace the line from week 32, replacing "sem 32" by "sem 33" in every newly paste entries.

  • 3
    \$\begingroup\$ Step one is to fix the formatting of your code. The VBA Rubberduck can correctly format your code for you: rubberduckvba.com \$\endgroup\$
    – HackSlash
    Aug 12, 2020 at 17:54
  • \$\begingroup\$ Cant add it to my job excel without askin the IT guys, may take a week or so... \$\endgroup\$ Aug 12, 2020 at 18:00
  • 1
    \$\begingroup\$ you can install in user mode without administrator. \$\endgroup\$
    – HackSlash
    Aug 12, 2020 at 19:46
  • \$\begingroup\$ Ok so il remind myself to always try before saying it dosn't work; its done now, thx Hack! \$\endgroup\$ Aug 12, 2020 at 19:55
  • \$\begingroup\$ Sample data would help. \$\endgroup\$
    – TinMan
    Aug 13, 2020 at 7:01

1 Answer 1


I don't see the need to find a specific row number. Simply work your way down until you reach the current week.

The key to reducing repeat code is to extract it to it's own method.

Refactored Code

Sub UpdateWeeklyReports()
    Application.ScreenUpdating = False
    Const WorksheetName As String = "Sheet1"
    Const FirstWeekNumberRow As Long = 3
    Dim LastWeek As Range
    Dim What As String, Replacement As String
    With Worksheets(WorksheetName)
        Dim Row As Long
        For Row = FirstWeekNumberRow + 1 To  Format(Now, "WW") - 1
            If Not .Cells(Row, 3).HasFormula Then
                ' What = "sem " & .Cells(Row - 1, 2).Value
                ' Replacement = "sem " & .Cells(Row, 2).Value
                AddNewRow SourceRange:=.Rows(Row - 1).Range("C1:J1"), What:=What, Replacement:=Replacement
                AddNewRow SourceRange:=.Rows(Row - 1).Range("M1:T1"), What:=What, Replacement:=Replacement
                AddNewRow SourceRange:=.Rows(Row - 1).Range("W1:AD1"), What:=What, Replacement:=Replacement
            End If
    End With
End Sub

Private Sub AddNewRow(ByVal SourceRange As Range, ByVal What As String, ByVal Replacement As String)
    With SourceRange
        .Offset(1).Formula = .Formula
        .Offset(1).Replace What:=What, Replacement:=Replacement, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    End With
End Sub

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.