Erreur 5854 paramètre de la chaîne trop long

Le 08/11/2022 à 15:51

Bonjour à tous,

Je suis bloqué par une erreur 5854 sur un myrange.find.execute FindText:=contenu lorque le contenu fait + de 250 caractères. Je n'arrive pas à contourner le problème.

Pour contextualiser, il s'agit de récupérer des données depuis le userform d'une bdd excel (ici dans une listview), et de générer un compte rendu sur word. Lors de la génération du compte rendu, il s'agit de chercher le contenu que l'on vient d'écrire et de le souligner sous certaines conditions (ici la condition est que le contenu soit en gras dans la listview). Mais si ce contenu est trop long, cela plante fait planter le programme...

Je vous joins un fichier excel épuré qui vise à isoler le problème. Il suffit d'avoir également un document word intitulé "Courrier Type" qui contienne un signet "Bilan".

27classeur1.xlsm (31.84 Ko)

Pour ceux qui veulent juste le code, je le mets en dessous.

Merci beaucoup !

Private Sub UserForm_Initialize()
  With ListView1

        .ColumnHeaders.Add Text:="Element du bilan", Width:=100
        .ColumnHeaders.Add Text:="Texte", Width:=550

        .ListItems.Clear
        .ListItems.Add Text:="Test"
        .ListItems(1).ListSubItems.Add Text:="Denique Antiochensis ordinis vertices sub uno elogio iussit occidi ideo efferatus, quod ei celebrari vilitatem"
        .ListItems(1).Bold = False
        .ListItems(1).ListSubItems(1).Bold = False
        .ListItems.Add Text:="TestLong"
        .ListItems(2).ListSubItems.Add Text:="Lorem ipsum dolor sit amet. Ut galisum eaque et perferendis asperiores aut sint aliquid et molestiae veritatis eum repellat voluptates hic animi aliquam qui aperiam quidem! Et consequatur esse et suscipit unde sed ipsam quas qui molestias optio qui sint dolorem. Id obcaecati sunt qui earum nemo est iste voluptatem sit obcaecati nihil. Qui saepe itaque nam eius nostrum eum unde internos ut voluptatibus sint aut eaque perferendis At dolorem enim?"
        .ListItems(2).Bold = False
        .ListItems(2).ListSubItems(1).Bold = False
        .ListItems.Add Text:="TestGrasLong"
        .ListItems(3).ListSubItems.Add Text:="ost haec indumentum regale quaerebatur et ministris fucandae purpurae tortis confessisque pectoralem tuniculam sine manicis textam, Maras nomine quidam inductus est ut appellant Christiani diaconus, cuius prolatae litterae scriptae Graeco sermone ad Tyrii textrini praepositum celerari speciem perurgebant quam autem non indicabant denique etiam idem ad usque discrimen vitae vexatus nihil fateri conpulsus est."
        .ListItems(3).Bold = True
        .ListItems(3).ListSubItems(1).Bold = True
        .ListItems.Add Text:="TestGras"
        .ListItems(4).ListSubItems.Add Text:="Quam ob rem circumspecta cautela observatum est deinceps et cum edita montium petere coeperint grassatores, "
        .ListItems(4).Bold = True
        .ListItems(4).ListSubItems(1).Bold = True

  End With
End Sub
Private Sub CommandButton1_Click()
  Dim WordApp As Word.Application
  'Dim tbl1 As Table, intitulé As String, contenu As String, colonne As Long, TailleCol1 As Long, TailleCol2 As Long, TailleCol3 As Long, TailleCol4 As Long
  Dim nom As String

    'L’ Instruction On Error si Word n'est pas déjà ouvert.
    On Error Resume Next
    ' Activez Word s'il est déjà ouvert.
    Set WordApp = GetObject(, "Word.Application")
    If Err.Number = 429 Then
      Err.Clear
      'Créez une application Word si Word n'est pas déjà ouvert.
      Set WordApp = CreateObject("word.application") 'ouvre session word et le fichier voulu
    End If
    On Error GoTo 0

    WordApp.Visible = True    ' Assurez-vous que l'application Word est visible.
    ' Activez l'application Word.
    WordApp.Activate
    Set WordDoc = WordApp.Documents.Open("C:\Users\arnau\Desktop\Logiciel Bilan Kiné\Courrier Type.docx") 'ouvre document Word, ici juste une page vierge avec un signet "Bilan"

    WordDoc.Activate

    WordApp.Selection.Goto What:=wdGoToBookmark, Name:="Bilan"
    WordDoc.Tables.Add Range:=WordApp.Selection.Range, NumRows:=1, NumColumns:=2
    Set tbl1 = WordDoc.Tables(1)

    For Each ligne In ListView1.ListItems
      If ligne.Checked = True Then   'ne rien faire si ligne cochée
      Else
        intitulé = ligne.Text & " : "
        contenu = ligne.ListSubItems(1).Text

        Set Col1 = tbl1.Columns(1).Cells(1).Range    'sur ce paragraphe on mesure la taille des colonnes pour après les comparer au moment de les remplir afin qu'elles ne soient aps déséquilibrées
        Col1.MoveEnd wdCharacter, -1
        TailleCol1 = Col1.ComputeStatistics(Statistic:=wdStatisticLines)
        Set Col2 = tbl1.Columns(2).Cells(1).Range
        Col2.MoveEnd wdCharacter, -1
        TailleCol2 = Col2.ComputeStatistics(Statistic:=wdStatisticLines)

        Select Case ligne.Text

        Case Is = "Test", "TestLong", "TestGras", "TestGrasLong"
          If TailleCol1 > TailleCol2 Then
            tbl1.Columns(2).Cells(1).Range.InsertAfter vbCrLf & intitulé & contenu
          Else
            tbl1.Columns(1).Cells(1).Range.InsertAfter vbCrLf & intitulé & contenu
          End If
        End Select

        Set myRange = WordDoc.Content            'mettre en gras tous les intitulés et souligner l'intitulé s'il est mis en gras dans le userform
        myRange.Find.Execute FindText:=intitulé, Forward:=True
        If myRange.Find.Found = True Then
          myRange.Bold = True
          If ligne.Bold = True Then
            myRange.Underline = wdUnderlineSingle
          Else
            myRange.Underline = wdUnderlineNone
          End If
        End If

          Set myRange = WordDoc.Content            'souligner le contenu s'il est mis en gras dans l'application.
          myRange.Find.Execute FindText:=contenu, Forward:=True
          If myRange.Find.Found = True Then
            If ligne.Bold = True Then
              myRange.Underline = wdUnderlineSingle
            Else
              myRange.Underline = wdUnderlineNone
            End If
          End If
        End If

    Next ligne

    nom = "Test"
    WordDoc.Fields.Update
    If Dir("C:\Users\arnau\Desktop\Logiciel Bilan Kiné\Comptes rendus\" & nom & ".docx") <> "" Then 'si le fichier existe déjà
      WordDoc.SaveAs Filename:="C:\Users\arnau\Desktop\Logiciel Bilan Kiné\Comptes rendus\" & nom & " " & Format(Now, "dd-mm-yy") & ".docx", FileFormat:=wdFormatDocumentDefault, LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
      CreateObject("WScript.Shell").Popup "Le fichier existe déjà et est enregistré sous : " & nom & " " & Format(Now, "dd-mm-yy") & ".docx", 2, "Sauvegarde réussie"
    Else
      WordDoc.SaveAs Filename:="C:\Users\arnau\Desktop\Logiciel Bilan Kiné\Comptes rendus\" & nom & ".docx", FileFormat:=wdFormatDocumentDefault, LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
    End If

End Sub
16classeur1.xlsm (31.84 Ko)
Le 10/11/2022 à 04:47

Bonjour,

On ne peut pas reproduire le souci, votre code utilise un fichier ".docx" que nous n'avons pas

Mais de toute façon effectivement... aucune idée non plus

A+

Le 10/11/2022 à 09:11

Pour le docx c'est un document vierge contenant simplement un signet "Bilan"

Rechercher des sujets similaires à "erreur 5854 parametre chaine trop long"