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

Turgon

XLDnaute Nouveau
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!
 

Turgon

XLDnaute Nouveau
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 :p
 

vgendron

XLDnaute Barbatruc
voila..
je pense avoir compris finalement

VB:
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

XLDnaute Nouveau
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

XLDnaute Nouveau
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!
 

Turgon

XLDnaute Nouveau
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

XLDnaute Barbatruc
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..?

VB:
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

XLDnaute Nouveau
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

XLDnaute Barbatruc
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
VB:
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

XLDnaute Barbatruc
avec la formule remise dans la feuille Messages

VB:
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
 

Discussions similaires

Réponses
0
Affichages
83
Réponses
1
Affichages
119
Réponses
11
Affichages
236
Réponses
5
Affichages
125

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 848
dernier inscrit
Djigbenou