VBA Si trouve une valeur Copie le reste du texte et boucle

Bonjour,

Pour commencer, je n'ai pas de fichier Excel à donner car très confidentiel.
J'ai besoin de votre aide svp et cette fois, c'est urgent ! Je ne trouve pas de réponse.

Ma cellule A135 de la feuille ORI2 =

Sheets("ORI2").Range("A135")

comporte un texte TROP LONG avec plusieurs fois la valeur ORI (suivi d'un chiffre).


Exemple :
ORI2 : La limite de caractères pour Twitter est 140. Un message texto SMS peut avoir jusqu'à 160 caractères. Les ponctuations = compter comme caractère.

ORI4 : Simplement limité à ça

ORI9 : Si tu savais lôngin

ORI13 : La limite de caractères pour Twitter est 140. Un message texto SMS peut avoir jusqu'à 160 caractères. Les ponctuations = compter comme caractère.

ORI1 à pouvant aller jusqu'à plus de ORI400...

DONC ce dont j'ai besoin
J'ai besoin d'une formule VBA pour qu'à chaque mot ORIXXX
que le texte se copie dans la cellule du bas, ainsi de suite !
(redimension de cellule si nécessaire)

SVP help, je n'ai pas du tout la maîtrise d'Excel et j'ai essayé de passer par plusieurs formules trouvées sur Internet (nombre de caractères...)

Je décourage mais je ne peux abandonner, c'est pour mon boulot !


Info facultative, je suis passée par ce genre de codes mais ça ne va pas du tout, ça coupe de partout :

Nombre de caractère avec le mot ORI

Sub maxi()
Dim x As Integer
'+10 pour etendre la zone de boucle ou + 20, peu importe, sinon la derniere ligne
'créer par VBA ne fait pas partie de la plage de calcul
For Each cell In Range("A135:A" & [A65000].End(xlUp).Row + 50)
    If Len(cell) > 200 Then
        For x = 1 To 20
        If Mid(cell, 230 - x, 1) = "*ORI*" Then Exit For
        Next x
 
    cell.Offset(1, 0).EntireRow.Insert
    cell.Offset(1, 0) = Right(cell, Len(cell) - 200 + x)
    cell.Value = Left(cell.Value, 200 - x)
    End If
Next cell
End Sub

ou encore saut de cellules à chaque nombre de caractères.

Sub Test()
MaLigne = 135 'premiere ligne a decortiquer
SuiteL = 137 'ligne de la cellule ou poser les caracteres

Caractere = Val(InputBox("Conseil : Environ 160 caractères pour 2 lignes de commentaires", "Indiquez le nombre de caractère que peut contenir une cellule"))
If Caractere = 0 Then Exit Sub

MaxLigneVide = 1 'defini apres combien de lignes trouvees vide la procédure s'arrete
Compteur = 0

Do While Compteur < MaxLigneVide
If Cells(MaLigne, 1).Value = "" Then Compteur = Compteur + 1 Else Compteur = 0
For y = 1 To Len(Cells(MaLigne, 1).Value) 'pour tous les caracteres de la cellule
Cells(SuiteL, 1).Value = Cells(SuiteL, 1).Value & Mid(Cells(MaLigne, 1).Value, y, 1)
If y Mod Caractere = 0 Then SuiteL = SuiteL + 1 'si le nb de caractere =Xnombre, incremente la ligne de destination
Next y
SuiteL = SuiteL + 1
MaLigne = MaLigne + 1
Loop

'Sheets("ORI2").Range("A135").ClearContents
End Sub

ou la fusion de cellule qui ne marche pas, mais c'est pas bon non plus cette technique (car trop peu d'options) :

Sub Fusionner()
    Dim i, Fin, Fin2 As Integer
    
   Fin = 159
   i = 135
   Fin2 = 187
        
        If Sheets("ORI2").Cells(i, 1).Value <> "" Then
                If Len(Cells(i, 1) < 1400) Then
                
                        'Fusionne et formatte
                        Range(Cells(i, 1), Cells(Fin, 1)).Select
                    With Selection
                        .HorizontalAlignment = xlGeneral
                        .VerticalAlignment = xlTop
                        .WrapText = True
                        .Orientation = 0
                        .AddIndent = False
                        .ShrinkToFit = False
                        .MergeCells = True
                        End With
                        Selection.Merge
                        
              ElseIf Sheets("ORI2").Cells(i, 1).Value <> "" And Len(Cells(i, 1) > 1400) Then
                              
                              
                            'Fusionne et formatte
                                Range(Cells(i, 1), Cells(Fin2, 1)).Select
                            With Selection
                                .HorizontalAlignment = xlGeneral
                                .VerticalAlignment = xlTop
                                .WrapText = True
                                .Orientation = 0
                                .AddIndent = False
                                .ShrinkToFit = False
                                .MergeCells = True
                                End With
                                Selection.Merge

        End If
        End If
End Sub

MERCI d'avance de votre aide