Mise en dynamique d'un code

Bonjour!

Nouvelle dans le VBA, je cherche à retravailler un code précédemment créée par un collègue pour un fichier bien spécifique afin de le rendre fonctionnel pour un cas général.

Il a utilisé des plages nommées dans le Name Manager. J'en suis donc arrivée à la conclusion qu'il fallait que je déclare ces plages de cellules comme variables dans mon code puis que je les spécifie afin que le code marche dans d'autres fichiers.

Je ne suis cependant pas certaine de ma manipulation et mon code me revient avec une erreur. Une idée de pourquoi ?

Code initial :

Sub CreateDuplicates()
    Dim lLastRow As Long, lRept As Long, arCust() As String, lCustNo As Long, x As Long
    Application.ScreenUpdating = False
    arCust() = Split(Range("J2"), " ")
    Sheet2.Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    lLastRow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    Sheet1.Range("H2:H" & lLastRow) = "=LEN(B2)-LEN(SUBSTITUTE(B2,"" "", """"))"
    Range("Data").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("LengthList"), unique:=True

    For lRept = 1 To Range("LengthList").CurrentRegion.Rows.Count - 1

        Range("DataOut").CurrentRegion.Offset(1, 0).ClearContents
        Range("crit").Cells(2, 1) = Range("LengthList").Cells(lRept + 1, 1)
        Range("Data").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("DataOut"), criteriarange:=Range("crit")
        arCust() = Split(Sheet2.Range("J2"), " ")
        lCustNo = UBound(arCust()) + 1
        lLastRow = Sheet2.Range("I" & Rows.Count).End(xlUp).Row
        For x = 0 To lCustNo - 1
            Sheet2.Range("J2:J" & lLastRow) = arCust(x)
            Range("Data_Temp").Offset(1, 0).Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Cells(2, 1)
        Next x

    Next lRept
    Application.ScreenUpdating = True

End Sub

J'ai repéré 4 plages de cellules nommées mais non définies :

• crit
• DataOut
• LengthList
• Data

J'ai simplement ajouté ceci au code précédent :

Dim DataOut As Range
    Set DataOut = Range("Duplicated!$I$1:$P$1")

    Dim Data As Range
    Set Data = Range("=OFFSET(ConsoSheet!$A$1;0;0;COUNTA(ConsoSheet!$A:$A);8)")

    Dim crit As Range
    Set crit = Range("=Duplicated!$R$1:$R$2")

    Dim LengthList As Range
    Set LengthList = Range("=ConsoSheet!$J$1")

Est-ce ainsi que l'on fait ?

J'ai un doute sur la variable Data, elle ne ressemble pas vraiment à une plage. Mais en même temps dans le code initial on fait référence à data en tant que range donc... (Range("Data").AdvancedFilter)

Bonjour Quisemar,

En regardant ton fichier, j'ai d'abord regardé les plages nommées, un très grand nombre posaient problème. Je les ai supprimés,

En cliquant sur ta fonction, aucun message d'erreur et aucune valeur vide dans ton tableau.

Vu que je ne sais pas comment fonctionne ton classeur ni ce que la fonction est censée faire, je pense que retirer les messages d'erreur c'est déjà un bon point =)

Bonjour

Pourquoi ne pas (re)créer ces noms

Sub CreateDuplicates()

  With ActiveWorkbook
    .Names.Add Name:="Data", RefersToR1C1:="=OFFSET(ConsoSheet!R1C1,0,0,COUNTA(ConsoSheet!C1),8)"
    .Names.Add Name:="Crit", RefersToR1C1:="=Duplicated!R1C18:R2C18"
    .Names.Add Name:="DataOut", RefersToR1C1:="=Duplicated!R1C9:R1C16"
    .Names.Add Name:="LengthList", RefersToR1C1:="=ConsoSheet!R1C10"
  End With

  Dim lLastRow As Long, lRept As Long, arCust() As String, lCustNo As Long, x As Long
  Application.ScreenUpdating = False
  arCust() = Split(Range("J2"), " ")
  Sheet2.Range("A1").CurrentRegion.Offset(1, 0).ClearContents
  lLastRow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
  Sheet1.Range("H2:H" & lLastRow) = "=LEN(B2)-LEN(SUBSTITUTE(B2,"" "", """"))"
  Range("Data").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("LengthList"), unique:=True

  For lRept = 1 To Range("LengthList").CurrentRegion.Rows.Count - 1

    Range("DataOut").CurrentRegion.Offset(1, 0).ClearContents
    Range("crit").Cells(2, 1) = Range("LengthList").Cells(lRept + 1, 1)
    Range("Data").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("DataOut"), criteriarange:=Range("crit")
    arCust() = Split(Sheet2.Range("J2"), " ")
    lCustNo = UBound(arCust()) + 1
    lLastRow = Sheet2.Range("I" & Rows.Count).End(xlUp).Row
    For x = 0 To lCustNo - 1
      Sheet2.Range("J2:J" & lLastRow) = arCust(x)
      Range("Data_Temp").Offset(1, 0).Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Cells(2, 1)
    Next x

  Next lRept
  Application.ScreenUpdating = True

End Sub