Code Extraction de mots à partir de cellules to colonnes

Version imprimable

26/09/2013, 16h19
alidroos

Code Extraction de mots à partir de cellules to colonnes

Bonjour tous

Une chaîne de texte dans une cellule constituée de deux langues
Extrait mots arabes dans une colonne
Et l'anglais dans la dernière colonne
exemple :
احمد محمد اسف نجدي Ahmad mohmmad asf nagde
colonne1 = احمد محمد اسف نجدي
colonne 2 = Ahmad mohmmad asf nagde

Car il ya plus conscients des différentes cellules des mots

Bonjour,

J'ai fait un test avec une seule cellule en A1
Je te laisse le soin de te faire une boucle si nécessaire...

Le principe que j'ai utilisé, c'est de mettre tous les mots dans un tableau et ensuite vérifier chaque élément pour les reconstruire. Dans mon système, les caractères des mots arabes ont 63 (?) comme code ASCII, alors je me sers de ça pour déterminer les mots français et ceux arabes et les reconstruire...

Si ça ne fonctionne pas de la même manière sur ton PC, alors, mon code ne te servira pas...
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub Extraire() Dim I As Long Dim Tablo() As String Dim strFR As String, strAR As String Tablo = Split(Range("A1"), " ") For I = 0 To UBound(Tablo) If Tablo(I) <> "" Then If Asc(Mid(Tablo(I), 1, 1)) <> 63 Then strFR = strFR & Tablo(I) & " " Else strAR = strAR & Tablo(I) & " " End If End If Next Range("B1") = Left(strFR, Len(strFR) - 1) Range("C1") = Left(strAR, Len(strFR) - 1) End Sub

26/09/2013, 18h57
Marc-L

Bonjour,

sur ma version après coller, l'anglais et l'arabe s'inverse dans la cellule …

Sinon parmi utilise AscW, c'est plus facile pour directement effectuer la séparation …
26/09/2013, 19h26
parmi

Bien vu Marc-L :ccool:
Je n'aurais pas pensé à ça...
Faut dire que je n'ai jamais eu à travailler avec de l'arabe...

Donc, on pourrait dire, j'imagine

Code:

If AscW(Mid(Tablo(I), 1, 1)) <= 255 then 'non arabe

plutôt que Asc(...) <> 63
26/09/2013, 19h36
Marc-L

Heu … Tu n'as pas besoin de Mid puisque la fonction Asc et dérivées renvoient le code du premier caractère d'une chaîne …

Ou > 255 pour de l'arabe, voir même beaucoup plus haut comme 1000 par exemple.
Le demandeur devrait connaitre à partir de quel n° de code ASCII étendu commence l'alphabet arabe …

Bon en fait pour l'inversion c'est normal à l'écran mais en interne l'ordre est bien respecté …

Donc voici une proposition sans utiliser volontairement Split :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 Sub Demo() TXT$ = Application.Trim([A1].Value) Do W% = AscW(Mid$(TXT, P& + 1)) If W And W < 1500 Then If P > 1 Then [B1].Value = Left$(TXT, P - 1) [C1].Value = Mid$(TXT, P + 1) Else [C1].Value = TXT End If Exit Do End If P = InStr(P + 1, TXT, " ") If P = 0 Then [B1].Value = TXT Loop Until P = 0 End Sub
:yaisse1:
__________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

__________________________________________________________________________________________
Un scientifique lira des centaines de livres au cours de sa vie, mais sera toujours persuadé qu'il lui reste beaucoup à apprendre.
Un religieux n'en lira qu'un et sera persuadé d'avoir tout compris …

Merci tout
Ce format fonctionne bien
Extraction et répète mais en gros deux fois et plus
J'espère que ça marchera sur Range [A1:A2000]

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Extraire()
    Dim I As Long
    Dim Tablo() As String
    Dim strFR As String, strAR As String
    Dim Rng As Range
    On Error Resume Next
    For Each Rng In Range("A1:A2000")
    Tablo = Split(Rng, " ")
    For I = 0 To UBound(Tablo)
        If Tablo(I) <> "" Then
            If Asc(Mid(Tablo(I), 1, 1)) < 195 Then
                strFR = strFR & Tablo(I) & " "
            Else
                strAR = strAR & Tablo(I) & " "
            End If
        End If
       Next
      Next
    Range("B1") = Left(strFR, Len(strFR) - 1)
    Range("C1") = Left(strAR, Len(strFR) - 1)
End Sub

A tester …

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub Demo()
    TA = [A1].Resize(Cells(Rows.Count, 1).End(xlUp).Row).Value
    L& = UBound(TA)
    ReDim BC$(1 To L, 1 To 2)
 
    For R& = 1 To L
        P& = 0
        T$ = Application.Trim(TA(R, 1))
 
        Do
            W% = AscW(Mid$(T, P& + 1))
 
            If W And W < 1500 Then
                If P > 1 Then
                    BC(R, 1) = Left$(T, P - 1)
                    BC(R, 2) = Mid$(T, P + 1)
                Else
                    BC(R, 2) = T
                End If
 
                Exit Do
            End If
 
            P = InStr(P + 1, T, " ")
            If P = 0 Then BC(R, 1) = T
        Loop Until P = 0
    Next
 
    [B1:C1].Resize(L).Value = BC
    Erase TA, BC
End Sub

:yaisse1:
__________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

__________________________________________________________________________________________
Quelle époque terrible que celle où des idiots dirigent des aveugles. (Shakespeare)

code
L'amendement suivant :ccool:
Merci Marc-L

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Public Sub Extr_Ali()
    Repl
    Lr = Cells(Rows.Count, 1).End(xlUp).Row
    For R = 1 To Lr
      Cells(R, 2) = Extraire(Cells(R, 1), 1)
      Cells(R, 3) = Extraire(Cells(R, 1), 0)
    Next
End Sub
Private Function Extraire(R As String, Bn As Boolean)
    Dim Tablo() As String
    Dim strFR As String, strAR As String
    Dim Ad
    Tablo = Split(R, " ")
    For I = 0 To UBound(Tablo)
        If Tablo(I) <> "" Then
            If Asc(Mid(Tablo(I), 1, 1)) < 195 Then
                strFR = strFR & Tablo(I) & " "
            Else
                strAR = strAR & Tablo(I) & " "
            End If
        End If
     Next
     If Bn Then Ad = strAR Else Ad = strFR
     Extraire = Ad
End Function
Private Function Repl()
With ActiveSheet.UsedRange.Columns(1)
    .Replace "-", "", xlPart
     .Replace "(", "", xlPart
    .Replace ")", "", xlPart
End With
End Function

Une autre approche utilisant les expressions régulières (lien utile)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub Main()
Dim LastLig As Long, i As Long
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")                          'à adapter
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 2 To LastLig
        .Range("B" & i).Resize(1, 2).Value = SepareEnAr(.Range("A" & i).Value)
    Next i
End With
End Sub
 
Private Function SepareEnAr(ByVal Tmp As String)
Dim En As String, Ar As String
Dim Rg As Object
 
Set Rg = CreateObject("VBScript.Regexp")
With Rg
    .Global = True
    .ignorecase = True
    .Pattern = "[\u0600-\u06FF]|\n|\-|\(|\)"
    En = Trim(.Replace(Tmp, ""))
    .Pattern = "\w|\n|\-|\(|\)"
    Ar = Trim(.Replace(Tmp, ""))
End With
Set Rg = Nothing
SepareEnAr = Array(Ar, En)
End Function

28/09/2013, 00h34
Marc-L

C'est beau les expressions régulières !

\u0600-\u06FF représente une plage Unicode je suppose …
28/09/2013, 00h48
mercatog

Citation:

Envoyé par Marc-L

C'est beau les expressions régulières !

\u0600-\u06FF représente une plage Unicode je suppose …

Oui c'est ça http://www.w3c.org.ma/Talks/copstic3/slide6-0.html
28/09/2013, 07h01
alidroos

Bonjour mercatog
Merci beaucoup

professeur programmation
code étrange
28/09/2013, 07h46
alidroos

Bonjour mercatog

"Ahmad Daybv Bakhe 050223311145"
[B1] = 050223311145
[C1] = Ahmad Daybv Bakhe

Si vous trouvez une chaîne de texte comme avant
Et je veux extraire uniquement les numéros ?

Lisez le lien donné pour apprendre

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub Main()
Dim LastLig As Long, i As Long
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")                          'à adapter
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 2 To LastLig
        .Range("B" & i).Resize(1, 2).Value = SepareEnNum(.Range("A" & i).Value)
    Next i
End With
End Sub
 
Private Function SepareEnNum(ByVal Tmp As String)
Dim En As String, Nm As String
Dim Rg As Object
 
Set Rg = CreateObject("VBScript.Regexp")
With Rg
    .Global = True
    .Pattern = "\d"                                ' .Pattern = "[\u0600-\u06FF]|\d|\n|\-|\(|\)" 'dans le cas où séparer les nombres comme les mots arabes
    En = Trim(.Replace(Tmp, ""))
    .Pattern = "[a-zA-Z]|\n|\-|\(|\)"
    Nm = "'" & Trim(.Replace(Tmp, ""))
End With
Set Rg = Nothing
SepareEnNum = Array(Nm, En)
End Function