مشكلة في ملف الاكسيل اللغة غلط

[redamohamed]

السلام عليكم
محتاج اظبط اللغة اللى في هذا الملف حيث اننى حاولت تعديل اعدادت اللغة في control panel لجهاز الكمبيوتر وكذلك اعدادت ملف الاكسيل ولم استطيع

فلو تكرمتوا لو يمكن ان تعدلوا الملف ؟

وجزاكم الله خيرا

3 شغل whatsapp310318.xlsx

[Foksh]

أخي الكريم وعليكم السلام ورحمة الله وبركاته ..

مشكلتك هي أنك استوردت الأسماء من ملف VCF ..

وهنا تم التشفير بصيغة يفهمها الهاتف الجوال سواءً أندرويد أو آيفون .

يعني على سبيل المثال :-

ظٹط§ط³ط±,ط´ظˆظƒظˆظ„ط§,ط¬ظ‡ظٹظ†ط©,,,,,,,,,,,,,,* myContacts,,,,,Mobile,+966541469114,,,,,,,,,,,,,,,

اسم جهة الاتصال: ياسر شوكولا جهينة
المجموعة: myContacts
رقم الهاتف (جوال): 966541469114+

 

وأنت ما شاء الله لديك 15155 اسم  😅 . لذا مشكلتك ليست بتغيير لغة الإعدادات في الويندوز أو الأكسل أو حتى بالخط . بل هي بنوع التشغير مثل UTF-8 ، لأنه سبق لي أن تعاملت مع هذه المشكلة في موضوع مرسال الواتس أب المحدث - الإصدار الرابع .

[Foksh]

وهذه محاولة يائسة باستخدام معالج التشفير الخاص بي ، ولكن من اكسيس طبعاً

Book2.xlsx

[redamohamed]

جزاء الله خيرا على سرعة الاستجابة
ويجعله في ميزان حسناتك ان شاء الله

لكن لم افهم نوع التشغير مثل UTF-8 

وقد قمت بنسخ اللغة الغريبة هذه في ملف txt  وقمت بتغيير التشفير الى UTF-8 ومازالت المشكلة موجودة

فهل هناك طريقة اخرى ؟

او لو تستطيع ان تساعدني بتغييرها من عندك وارسالها لي مرة اخرى في ملف ؟

[أبوعيد]

تم تعديل الملف كاملا 

والكود بداخله بالاستعانة بالذكاء الاصطناعي
 

Sub FixArabicEncoding()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' يمكنك تغييرها حسب الحاجة

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim Cell As Range
    Dim OriginalText As String
    Dim Bytes() As Byte
    Dim FixedText As String

    Application.ScreenUpdating = False

    For Each Cell In ws.Range("A1:A" & LastRow)
        If Not IsEmpty(Cell.Value) Then
            OriginalText = Cell.Value

            ' تحويل النص إلى بايتات (بافتراض أنها ANSI مشفوعة)
            Bytes = StrConv(OriginalText, vbFromUnicode)

            ' إعادة تفسير البايتات كـ UTF-8 (باستخدام ترميز UTF-8 للإخراج)
            ' نحتاج إلى استخدام ADODB.Stream لذلك
            FixedText = UTF8BytesToString(Bytes)

            ' إذا كان النص الجديد يحتوي على نص عربي صحيح، نُحدّث الخلية
            If ContainsArabic(FixedText) Then
                Cell.Value = FixedText
            Else
                ' اختيار بديل: محاولة تفسيره كـ Windows-1256 (العربية الشائعة)
                FixedText = BytesToString_ANSI(Bytes)
                If ContainsArabic(FixedText) Then
                    Cell.Value = FixedText
                End If
            End If
        End If
    Next Cell

    Application.ScreenUpdating = True
    MsgBox "تم تصحيح الترميز بنجاح! تحقق من البيانات.", vbInformation
End Sub

' --- دوال مساعدة ---

' دالة: تحويل بايتات إلى نص باستخدام UTF-8
Function UTF8BytesToString(Bytes() As Byte) As String
    Dim Stream As Object
    Set Stream = CreateObject("ADODB.Stream")
    With Stream
        .Type = 1 ' adTypeBinary
        .Open
        .Write Bytes
        .Position = 0
        .Type = 2 ' adTypeText
        .Charset = "utf-8"
        UTF8BytesToString = .ReadText
        .Close
    End With
End Function

' دالة: تحويل بايتات إلى نص باستخدام Windows-1256 (العربية)
Function BytesToString_ANSI(Bytes() As Byte) As String
    Dim Temp As String
    Temp = StrConv(Bytes, vbUnicode)
    BytesToString_ANSI = StrConv(Temp, vbFromUnicode)
End Function

' دالة: تحقق من وجود نص عربي في النص (لتجنب التحديثات غير الضرورية)
Function ContainsArabic(Text As String) As Boolean
    Dim i As Long
    For i = 1 To Len(Text)
        If AscW(Mid(Text, i, 1)) >= &H600 And AscW(Mid(Text, i, 1)) <= &H6FF Then
            ContainsArabic = True
            Exit Function
        End If
    Next i
    ContainsArabic = False
End Function
                                                                           

 

الملف كاملا مع الكود.xlsm

تم تعديل الأربعاء at 10:55 بواسطه أبوعيد