XL 2019 Copier une partie de contenu d'une cellule dans une autre - Macro

[Blessmywill]

Bonjour à tous,

Je suis traducteur et prof domicilié à Pékin. Dans le cadre de mon travail, je reçois des fichiers de glossaire de mes collègues chinois. Même je leur dis souvent de mettre les infos dans deux colonnes distinctes, c'est rarement fait 🙂

J'aimerais du coup trouver une macro qui me permette de séparer le texte en chinois du texte français.

Je suis débutant en macro, donc tous vos conseils et votre aide sont les bienvenus.
Je vous laisse un document pour vous montrer ce que je souhaiterai obtenir comme résultat.

Bien à vous,

 

[Bernard_XLD]

Re bonjour Blessmywill, le fil

Bernard_XLD, tout fonctionne sauf si le texte Français est collé (pas d'espace) avec le texte chinois dans les post 10 et 12.

Bon, là, j'ai creusé car je ne comprenais plus. En fait le problème vient de Ascw censé renvoyer un code caractère mondial entre 1 et 65535. Apparemment, VB code les 65535 caractères Ascw sur un entier et non un long et renvoie une valeur supérieure à 32768 en valeur négative à -32768.
voila le code modifié et fournissant, cette fois ci, une chaine correcte dans tous les cas de figure ( ou alors je rirai jaune )
cela fonctionnera aussi pour d'autres langues que le chinois.

Bien cordialement

code fonction

Function CH_FR$(Target As Range, Retour$)
    Dim Compteur As Integer, Compteur2 As Integer, Compteur3 As Integer, Texte_Cellule$
    Texte_Cellule = Target.FormulaR1C1
    'détecte le premier caractère > 255
    For Compteur = 1 To Len(Texte_Cellule)
        If AscW(Mid(Texte_Cellule, Compteur, 1)) > 255 Or AscW(Mid(Texte_Cellule, Compteur, 1)) < 0 Then
            Compteur2 = Compteur
            Exit For
        End If
    Next Compteur
    'détecte le dernier caractère >255
    If Compteur2 > 0 Then
        For Compteur = Len(Texte_Cellule) - 1 To 0 Step -1
            If AscW(Mid(Texte_Cellule, Compteur, 1)) > 255 Or AscW(Mid(Texte_Cellule, Compteur, 1)) < 0 Then
                Compteur3 = Compteur
                Exit For
            End If
        Next Compteur
    End If
    'retour selon param
    Select Case UCase(Retour)
    Case Is = "CH"
        If Compteur2 = 0 Then CH_FR = "" Else CH_FR = Mid(Texte_Cellule, Compteur2, Compteur3 - Compteur2 + 1)
    Case Is = "FR"
        If Compteur2 = 0 Then CH_FR = Texte_Cellule Else CH_FR = LTrim(Right(Texte_Cellule, Len(Texte_Cellule) - Compteur3))
    Case Else
        CH_FR = "Paramètre incorrect (CH ou FR)"
    End Select
End Function

ou code macro

Sub CH_FR2()
    Dim Cellule_en_Cours As Range, Compteur As Integer, Compteur2 As Integer, Compteur3 As Integer, Texte_Cellule$
    'détecte le premier caractère > 255
    For Each Cellule_en_Cours In Range("A1:A" & Range("A65536").End(xlUp).Row)
        Texte_Cellule = Cellule_en_Cours.FormulaR1C1
        Compteur2 = 0
        Compteur3 = 0
        For Compteur = 1 To Len(Texte_Cellule)
            If AscW(Mid(Texte_Cellule, Compteur, 1)) > 255 Or AscW(Mid(Texte_Cellule, Compteur, 1)) < 0 Then
                Compteur2 = Compteur
                Exit For
            End If
        Next Compteur
        'détecte le dernier caractère > 255
        If Compteur2 > 1 Then
            For Compteur = Len(Texte_Cellule) To 1 Step -1
                If AscW(Mid(Texte_Cellule, Compteur, 1)) > 255 Or AscW(Mid(Texte_Cellule, Compteur, 1)) < 0 Then
                    Compteur3 = Compteur
                    Exit For
                End If
            Next Compteur
        End If
        'retour selon param
        If Compteur2 = 0 Then
            Cellule_en_Cours.Offset(0, 2).FormulaR1C1 = Texte_Cellule
        Else
            Cellule_en_Cours.Offset(0, 1).FormulaR1C1 = Mid(Texte_Cellule, Compteur2, Compteur3 - Compteur2 + 1)
            Cellule_en_Cours.Offset(0, 2).FormulaR1C1 = LTrim(Right(Texte_Cellule, Len(Texte_Cellule) - Compteur3))
        End If
    Next Cellule_en_Cours
End Sub

 

[Blessmywill]

Bonjour Bernard_XLD,

C'est juste parfait. C'est un outil tout simplement génial que tu viens de créer ! Je te remercie du fond du cœur pour ta détermination ! Aucun souci rencontré, cet outil fonctionne aussi avec d'autres langues, je confirme !!!

Un grand merci à toi et à toute la communauté, vous êtes au top !

 

[Bernard_XLD]

Re le fil, le forum

pour le fun, ,la même macro avec un tableau, cela restera très rapide même sur un très grand nombre de données à traiter.

Bien cordialement

Sub CH_FR3()
    Dim Tableau_en_Cours, Tableau_Range As Range, Compteur As Integer, Compteur2 As Integer, Compteur3 As Integer, Compteur4 As Long, Texte_Cellule$
    Set Tableau_Range = Range("A1:C" & Range("A1000000").End(xlUp).Row)
    Tableau_en_Cours = Tableau_Range.Value
    'détecte le premier caractère > 255
    For Compteur4 = LBound(Tableau_en_Cours, 1) To UBound(Tableau_en_Cours, 1)
        Compteur2 = 0
        Compteur3 = 0
        Texte_Cellule = Tableau_en_Cours(Compteur4, 1)
        For Compteur = 1 To Len(Texte_Cellule)
            If AscW(Mid(Texte_Cellule, Compteur, 1)) > 255 Or AscW(Mid(Texte_Cellule, Compteur, 1)) < 0 Then
                Compteur2 = Compteur
                Exit For
            End If
        Next Compteur
        'détecte le dernier caractère > 255
        If Compteur2 > 0 Then
            For Compteur = Len(Texte_Cellule) To 1 Step -1
                If AscW(Mid(Texte_Cellule, Compteur, 1)) > 255 Or AscW(Mid(Texte_Cellule, Compteur, 1)) < 0 Then
                    Compteur3 = Compteur
                    Exit For
                End If
            Next Compteur
        End If
        'retour selon param
        If Compteur2 = 0 Then
            Tableau_en_Cours(Compteur4, 3) = Texte_Cellule
        Else
            Tableau_en_Cours(Compteur4, 2) = Mid(Texte_Cellule, Compteur2, Compteur3 - Compteur2 + 1)
            Tableau_en_Cours(Compteur4, 3) = LTrim(Right(Texte_Cellule, Len(Texte_Cellule) - Compteur3))
        End If
    Next Compteur4
    Application.Calculation = xlCalculationManual
    Tableau_Range.Value = Tableau_en_Cours
    Application.Calculation = xlCalculationAutomatic
    Set Tableau_en_Cours = Nothing
    Set Tableau_Range = Nothing
End Sub

 

[job75]

Bonjour,

cet outil fonctionne aussi avec d'autres langues, je confirme !!!

A condition qu'elles n'utilisent pas l'alphabet latin !

A+

 

[Bernard_XLD]

Salut Job

A condition qu'elles n'utilisent pas l'alphabet latin !

Tout à fait, c'est même le principe sur lequel est basée cette macro, j'aurai du le préciser.
Bonne journée!
Bien cordialement.

 

[job75]

Tout à fait, c'est même le principe sur lequel est basée cette macro, j'aurai du le préciser.

Ce n'est vraiment pas la peine et je ne l'ai pas fait non plus pour la mienne.

 

[Blessmywill]

Bonsoir à vous deux,

Je garde vos deux solutions car elles me conviennent également, et ce sont des approches différentes qui me permettront de mieux comprendre ce monde de la VBA