XL 2016 VBA "traduction" de validation de données

[Turgon]

Bonjour à tous, et excusez-moi par avance si le sujet a déjà été posté, mais je ne l'ai pas trouvé sur le fil de discussions.

J'ai hérité d'une macro, qui, comme le titre l'indique, vise à traduire toutes mes validations de données dans une feuille de travail.
-Une première partie, qui collecte toutes les validations de données et me les affiche dans un tableau, sur un feuillet qui se crée, nommé "messages". Texte ci-dessous:


Sub GetMessages()
'
Dim i As Integer
Dim myM As Worksheet
Dim myC As Range
Dim myRow As Long
Dim myCalc As XlCalculation
With Application
.DisplayAlerts = False
.EnableEvents = False
myCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set myM = Worksheets.Add(before:=Worksheets(1))
myM.Name = "Messages"
myM.Cells(1, 1).Value = "Address"
myM.Cells(1, 2).Value = "Existing Input Title"
myM.Cells(1, 3).Value = "Existing InputMessage"
myM.Cells(1, 4).Value = "Existing Error Title"
myM.Cells(1, 5).Value = "Existing Error Message"
myM.Cells(1, 6).Value = "Translated Input Title"
myM.Cells(1, 7).Value = "Translated InputMessage"
myM.Cells(1, 8).Value = "Translated Error Title"
myM.Cells(1, 9).Value = "Translated Error Message"
myM.Rows(1).Cells.WrapText = True
On Error GoTo NoValidation
For i = 2 To Worksheets.Count
For Each myC In Worksheets(i).Cells.SpecialCells(xlCellTypeAllValidation)
myRow = myM.Cells(Rows.Count, 1).End(xlUp).Row + 1
myM.Cells(myRow, 1).Value = myC.Address(False, False, xlA1, True)
If myC.Validation.ShowInput Then
myM.Cells(myRow, 2).Value = myC.Validation.InputTitle
myM.Cells(myRow, 3).Value = myC.Validation.InputMessage
End If
If myC.Validation.ShowError Then
myM.Cells(myRow, 4).Value = myC.Validation.ErrorTitle
myM.Cells(myRow, 5).Value = myC.Validation.ErrorMessage
End If
Next myC
NoValidation:
Next i
With myM.Cells
.ColumnWidth = 16.43
.EntireRow.AutoFit
End With
With myM.Range("A1").CurrentRegion
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With

With Application
.DisplayAlerts = True
.EnableEvents = True
.Calculation = myCalc
End With
End Sub
--------------------------------------------------------------------------------------------------------------------------------Jusqu'ici tout va bien, la macro marche.
J'ai ensuite traduit chaque validation de données (titre d'entrée, message d'entrée, titre d'erreur, message d'erreur) en utilisant un autre feuillet ou j'ai copié le tableau obtenu, retiré les duplicats (j'avais 1700+ traductions à faire sinon), traduit, puis utilisé un VLOOKUP dans le tableau original.

-Deuxième macro, qui est censée remplacer le texte existant par sa traduction.

Sub UpdateMessages()
Dim myM As Worksheet
Dim i As Long
Set myM = Worksheets("Messages")
For i = 2 To myM.Cells(Rows.Count, 1).End(xlUp).Row
With Range(myM.Cells(i, 1).Value)
If myM.Cells(i, 2).Value <> "" Then .Validation.InputTitle = myM.Cells(i, 6).Value
If myM.Cells(i, 3).Value <> "" Then .Validation.InputMessage = myM.Cells(i, 7).Value
If myM.Cells(i, 4).Value <> "" Then .Validation.ErrorTitle = myM.Cells(i, 8).Value
If myM.Cells(i, 5).Value <> "" Then .Validation.ErrorMessage = myM.Cells(i, 9).Value
End With
Next i
End Sub
--------------------------------------------------------------------------------------------------------------------------------Et là erreur 400. En exécutant la macro avec F8, j'obtiens une erreur 1004: "application defined or object defined error" au niveau de la ligne rouge.

Débutant en VBA, je viens vers vous avec comme espoir:

1) de faire marcher ma macro

2) de comprendre pourquoi celle-ci ne marche pas.

Bonne journée, et merci d'avance!

 

[vgendron]

Hello

sans fichier pour tester.. essai de remplacer
With Range(myM.Cells(i, 1).Value)
par
With Range(myM.Cells(i, 1))

parce que sinon. tu essaies de mettre une liste de validation à une valeur...

 

[Turgon]

J'avais oublié de poster le fichier, désolé!

 

[vgendron]

Je ne comprends pas ce que tu essaies de faire dans ta feuille Messages..??
tu veux mettre une validation de données sur la colonne A ??

 

[Turgon]

Ce que je veux faire, c'est remplacer toutes mes bulles/messages texte de data validation dans chaque feuillet du fichier excel. Ils sont actuellement en anglais, je les veux en francais.

La feuille Messages se crée toute seule, grâce à la macro numéro 1 (Get Messages). Ensuite, j'ai traduit le texte anglais pour chaque cellule, et l'ai placé dans les colonnes correspondantes du feuillet Messages(Translated title, Translated error message, etc...). Ma deuxième macro est censée remplacer mes data validation en anglais par leur traduction en francais, directement dans les feuillets. J'espère que c'était clair

 

[vgendron]

voila..
je pense avoir compris finalement

Sub UpdateMessages()
    Dim myM As Worksheet
    Dim tablo() As Variant
    Dim i As Long
    Set myM = Worksheets("Messages")
    With myM
        fin = .Range("A" & .Rows.Count).End(xlUp).Row
        tablo = Range("A2:I" & fin).Value
    End With
    For i = LBound(tablo, 1) To UBound(tablo, 1)
        feuille = Split(Split(tablo(i, 1), "]")(1), "'")(0)
        cellule = Split(tablo(i, 1), "!")(1)
        With Sheets(feuille).Range(cellule).Validation
            If tablo(i, 2) <> "" Then .InputTitle = tablo(i, 6)
            If tablo(i, 3) <> "" Then .InputMessage = tablo(i, 7)
            If tablo(i, 4) <> "" Then .ErrorTitle = Left(tablo(i, 8), 32) 'pour le message d'erreur, il y a 32 caractères maximum autorisés
            If tablo(i, 5) <> "" Then .ErrorMessage = tablo(i, 9)
        End With
    Next i
End Sub

 

[Turgon]

Sub UpdateMessages()
Dim myM As Worksheet
Dim tablo() As Variant
Dim i As Long
Set myM = Worksheets("Messages")
With myM
fin = .Range("A" & .Rows.Count).End(xlUp).Row
tablo = Range("A2:I" & fin).Value
End With
For i = LBound(tablo, 1) To UBound(tablo, 1)
feuille = Split(Split(tablo(i, 1), "]")(1), "'")(0)
cellule = Split(tablo(i, 1), "!")(1)
With Sheets(feuille).Range(cellule).Validation
If tablo(i, 2) <> "" Then .InputTitle = tablo(i, 6)
If tablo(i, 3) <> "" Then .InputMessage = tablo(i, 7)
If tablo(i, 4) <> "" Then .ErrorTitle = Left(tablo(i, 8), 32) 'pour le message d'erreur, il y a 32 caractères maximum autorisés
If tablo(i, 5) <> "" Then .ErrorMessage = tablo(i, 9)
End With
Next i
End Sub

 

[Turgon]

Merci beaucoup pour ton aide! Un autre message d'erreur s'affiche à présent, "out of range subscript". Juste pour être sûr, j'ai juste besoin de cliquer sur ma macro depuis le feuillet "Messages", ou il faut que je lance la macro feuillet par feuillet?

Encore merci pour le temps consacré,

Bonne journée!

 

[vgendron]

non une seule fois suffit puisque TOUTES tes validations du classeur sont dans la feuille Messages

le out of range apparait à quelle ligne?
il faut juste etre sur que la fonction split te donne bien le nom des feuilles et cellules...

 

[Turgon]

Sub UpdateMessages()
Dim myM As Worksheet
Dim tablo() As Variant
Dim i As Long
Set myM = Worksheets("Messages")
With myM
fin = .Range("A" & .Rows.Count).End(xlUp).Row
tablo = Range("A2:I" & fin).Value
End With
For i = LBound(tablo, 1) To UBound(tablo, 1)
feuille = Split(Split(tablo(i, 1), "]")(1), "'")(0)
cellule = Split(tablo(i, 1), "!")(1)
With Sheets(feuille).Range(cellule).Validation
If tablo(i, 2) <> "" Then .InputTitle = tablo(i, 6)
If tablo(i, 3) <> "" Then .InputMessage = tablo(i, 7)
If tablo(i, 4) <> "" Then .ErrorTitle = Left(tablo(i, 8), 32) 'pour le message d'erreur, il y a 32 caractères maximum autorisés
If tablo(i, 5) <> "" Then .ErrorMessage = tablo(i, 9)
End With
Next i
End Sub


Le out of range apparaît à cette ligne

 

[vgendron]

avec ce code.. ca te dit à quelle ligne la macro plante
je te laisse regarder si il n'y a pas encore un pb de longueur de texte..?

Sub UpdateMessages()
    Dim myM As Worksheet
    Dim tablo() As Variant
    Dim i As Long
    Set myM = Worksheets("Messages")
    With myM
        fin = .Range("A" & .Rows.Count).End(xlUp).Row
        tablo = Range("A2:I" & fin).Value
    End With
    For i = LBound(tablo, 1) To UBound(tablo, 1)
   
        feuille = Split(Split(tablo(i, 1), "]")(1), "'")(0)
        cellule = Split(tablo(i, 1), "!")(1)
        On Error GoTo fin
        With Sheets(feuille).Range(cellule).Validation
            If tablo(i, 2) <> "" Then .InputTitle = tablo(i, 6)
            If tablo(i, 3) <> "" Then .InputMessage = tablo(i, 7)
            If tablo(i, 4) <> "" Then .ErrorTitle = Left(tablo(i, 8), 32) 'pour le message d'erreur, il y a 32 caractères maximum autorisés
            If tablo(i, 5) <> "" Then .ErrorMessage = tablo(i, 9)
        End With
    Next i
fin:
  MsgBox "erreur à la ligne: " & i + 1
End Sub

 

[Turgon]

Je vais regarder tout ca, merci encore pour ton aide

 

[Turgon]

Rebonjour! Alors, avec la macro que tu m'as donné, il me dit que l'erreur se trouve à la ligne 347. Je croyais que c'était à cause de la limitation à 32 caractères, mais quand j'ai essayé de changer (j'ai mis 300) ca, il me trouvait l'erreur à la ligne 2. J'avoue que je ne comprends pas.

 

[vgendron]

l'erreur vient du fait que ta liste dans la feuille Message est fausse...
il y a des lignes qui indiquent une validation dans une cellule..alors qu'après vérification, cette cellule n'a PAS de validation..
donc.. le code essaie de modifier une validation qui n'existe pas... donc bug

modifies ton code de la première macro pour tout effacer avant de relancer

Sub GetMessages()
'
    Dim i As Integer
    Dim myM As Worksheet
    Dim myC As Range
    Dim myRow As Long
    Dim myCalc As XlCalculation

    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        myCalc = .Calculation
        .Calculation = xlCalculationManual
    End With
    If Not (FeuilleExiste("Messages")) Then

        Set myM = Worksheets.Add(before:=Worksheets(1))
        myM.Name = "Messages"
        myM.Cells(1, 1).Value = "Address"
        myM.Cells(1, 2).Value = "Existing Input Title"
        myM.Cells(1, 3).Value = "Existing InputMessage"
        myM.Cells(1, 4).Value = "Existing Error Title"
        myM.Cells(1, 5).Value = "Existing Error Message"
        myM.Cells(1, 6).Value = "Translated Input Title"
        myM.Cells(1, 7).Value = "Translated InputMessage"
        myM.Cells(1, 8).Value = "Translated Error Title"
        myM.Cells(1, 9).Value = "Translated Error Message"
        myM.Rows(1).Cells.WrapText = True
    Else
        Set myM = Sheets("Messages")
        With myM
            .UsedRange.Offset(1, 0).Clear '!!! il faudra remettre les formules pour les traductions
        End With
    End If
   


    On Error GoTo NoValidation
    For i = 2 To Worksheets.Count
        For Each myC In Worksheets(i).Cells.SpecialCells(xlCellTypeAllValidation)
            myRow = myM.Cells(Rows.Count, 1).End(xlUp).Row + 1
            myM.Cells(myRow, 1).Value = myC.Address(False, False, xlA1, True)
            If myC.Validation.ShowInput Then
                myM.Cells(myRow, 2).Value = myC.Validation.InputTitle
                myM.Cells(myRow, 3).Value = myC.Validation.InputMessage
            End If
            If myC.Validation.ShowError Then
                myM.Cells(myRow, 4).Value = myC.Validation.ErrorTitle
                myM.Cells(myRow, 5).Value = myC.Validation.ErrorMessage
            End If
        Next myC
NoValidation:
    Next i

    With myM.Cells
        .ColumnWidth = 16.43
        .EntireRow.AutoFit
    End With

    With myM.Range("A1").CurrentRegion
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End With
   
    With Application
        .DisplayAlerts = True
        .EnableEvents = True
        .Calculation = myCalc
    End With
End Sub

Sub UpdateMessages()
    Dim myM As Worksheet
    Dim tablo() As Variant
    Dim i As Long
    Set myM = Worksheets("Messages")
    With myM
        fin = .Range("A" & .Rows.Count).End(xlUp).Row
        tablo = Range("A2:I" & fin).Value
    End With
    For i = LBound(tablo, 1) To UBound(tablo, 1)
       
        feuille = Split(Split(tablo(i, 1), "]")(1), "'")(0)
        cellule = Split(tablo(i, 1), "!")(1)

        With Sheets(feuille).Range(cellule).Validation
            If tablo(i, 2) <> "" Then .InputTitle = Left(Trim(tablo(i, 6)), 10)
            If tablo(i, 3) <> "" Then .InputMessage = Left(tablo(i, 7), 20)
            If tablo(i, 4) <> "" Then .ErrorTitle = Left(tablo(i, 8), 32) 'pour le message d'erreur, il y a 32 caractères maximum autorisés
            If tablo(i, 5) <> "" Then .ErrorMessage = Left(tablo(i, 9), 20)
        End With
    Next i

End Sub

Function FeuilleExiste(NomFeuille As String)
FeuilleExiste = False
For Each ws In ActiveWorkbook.Sheets
    If ws.Name = NomFeuille Then
        FeuilleExiste = True
        Exit For
    End If
Next ws

End Function

 

[vgendron]

avec la formule remise dans la feuille Messages

Sub GetMessages()
'
Dim i As Integer
    Dim myM As Worksheet
    Dim myC As Range
    Dim myRow As Long
   
   
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .DisplayAlerts = False
End With


If Not (FeuilleExiste("Messages")) Then

    Set myM = Worksheets.Add(before:=Worksheets(1))
    myM.Name = "Messages"
    myM.Cells(1, 1).Value = "Address"
    myM.Cells(1, 2).Value = "Existing Input Title"
    myM.Cells(1, 3).Value = "Existing InputMessage"
    myM.Cells(1, 4).Value = "Existing Error Title"
    myM.Cells(1, 5).Value = "Existing Error Message"
    myM.Cells(1, 6).Value = "Translated Input Title"
    myM.Cells(1, 7).Value = "Translated InputMessage"
    myM.Cells(1, 8).Value = "Translated Error Title"
    myM.Cells(1, 9).Value = "Translated Error Message"
    myM.Rows(1).Cells.WrapText = True
Else
    Set myM = Sheets("Messages")
    With myM
        .UsedRange.Offset(1, 0).Clear
    End With
End If
   
   

For i = 2 To Worksheets.Count 'chez moi. ca plante sur la dernière feuille.. le On error ne semble rien faire...
On Error GoTo NoValidation
    For Each myC In Worksheets(i).Cells.SpecialCells(xlCellTypeAllValidation)
        myRow = myM.Cells(Rows.Count, 1).End(xlUp).Row + 1
        myM.Cells(myRow, 1).Value = myC.Address(False, False, xlA1, True)
        If myC.Validation.ShowInput Then
            myM.Cells(myRow, 2).Value = myC.Validation.InputTitle
            myM.Cells(myRow, 3).Value = myC.Validation.InputMessage
        End If
        If myC.Validation.ShowError Then
            myM.Cells(myRow, 4).Value = myC.Validation.ErrorTitle
            myM.Cells(myRow, 5).Value = myC.Validation.ErrorMessage
        End If
    Next myC
NoValidation:
Next i
   
    formule = "=SIERREUR(RECHERCHEV(B2;Translation!B$1:$I$60;5;FAUX);"""")"
    Range("F2").FormulaLocal = formule
    Range("F2:I2").FillRight
    Range("F2:I2").Resize(myRow - 1).FillDown
    With myM.Cells
        .ColumnWidth = 16.43
        .EntireRow.AutoFit
    End With

    With myM.Range("A1").CurrentRegion
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End With
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

Sub UpdateMessages()
    Dim myM As Worksheet
    Dim tablo() As Variant
    Dim i As Long
    Set myM = Worksheets("Messages")
    With myM
        fin = .Range("A" & .Rows.Count).End(xlUp).Row
        tablo = Range("A2:I" & fin).Value
    End With
    For i = LBound(tablo, 1) To UBound(tablo, 1)
       
        feuille = Split(Split(tablo(i, 1), "]")(1), "'")(0)
        cellule = Split(tablo(i, 1), "!")(1)

        With Sheets(feuille).Range(cellule).Validation
            If tablo(i, 2) <> "" Then .InputTitle = Left(Trim(tablo(i, 6)), 10)
            If tablo(i, 3) <> "" Then .InputMessage = Left(tablo(i, 7), 20)
            If tablo(i, 4) <> "" Then .ErrorTitle = Left(tablo(i, 8), 32) 'pour le message d'erreur, il y a 32 caractères maximum autorisés
            If tablo(i, 5) <> "" Then .ErrorMessage = Left(tablo(i, 9), 20)
        End With
    Next i

End Sub

Function FeuilleExiste(NomFeuille As String)
FeuilleExiste = False
For Each ws In ActiveWorkbook.Sheets
    If ws.Name = NomFeuille Then
        FeuilleExiste = True
        Exit For
    End If
Next ws

End Function