ياسر خليل أبو البراء

الأخ الكريم أبو عبد الرحمن يرجى تغيير اسم الظهور للغة العربية إليك الملف المرفق Book1.rar

أخي الغالي المتميز مختار يعجبني أسلوبك في التعامل مع الأكواد ..أسلوب جديد ومميز ورائع جزيت خيراً على الموضوع الرائع والذي يستحق منا أن نصفق له بحرارة

أبي الحبيب أبو يوسف دائماً ما تتفوق علينا بكلماتك الرقيقة الطيبة ..بارك الله فيك وجزيت خير الجزاء أخي الحبيب المتميز المغازل رمهان بصراحة أحلى غزل وأحلى دالة في الموضوع ..مشكور على المشاركة بهذه الدالة المميزة الأخ الكريم قلم الإكسيل الحمد لله أن تم المطلوب على خير ونورت المنتدى بين إخوانك وننتظر منك التواجد بيننا لنستفيد منك وتستفيد منا تقبلوا تحياتي

بسم الله ما شاء الله ألف ألف مبروك أخي وحبيبي يحيى حسين أنت تستحقها بجدارة ... بس تعال قولي هنا : كيف حصلت عليها ؟ هل هذه الشهادة تقدم من خلال مسابقة .. نريد أن نعرف التفاصيل؟ تقبل تحياتي

الحمد لله الذي بنعمته تتم الصالحات جزيت خيراً على دعواتك الطيبة تقبل تحياتي

جرب الدالة التالية Function YK(sInp As String) As Long Static bInit As Boolean Dim asMap() As String Dim asLtr() As String Dim I As Long Static aiVal(0 To 255) As Long If Not bInit Then asMap = Split("1 1 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 26 27 28") asLtr = Split("أ ا إ ب ت ث ج ح خ د ذ ر ز س ش ص ض ط ظ ع غ ف ق ك ل م ن ه ة و ي") For I = 0 To UBound(asMap) aiVal(Asc(asLtr(I))) = asMap(I) Next I bInit = True End If For I = 1 To Len(sInp) YK = YK + aiVal(Asc(Mid(sInp, I, 1))) Next I End Function Sum Letters YasserKhalil V3.rar

الملف يعمل معي بدون أي مشكلة وبنتائج صحيحة ننتظر رأي الأخوة الذين جربوا الملف للتأكد من صحة الكود .. وسأحاول أن أقدم دالة أخرى ..

أخي الكريم لا علاقة بواجهة الإكسيل ..أنا أعمل على نسخة أوفيس 2013 الإنجليزية وليست العربية وتعمل معي الدالة بكفاءة ما هي نسخة الأوفيس لديك؟ هل هناك أي مشاكل بنسخة الأوفيس؟ لا تيأس وكرر المحاولة ويرجى من الأخوة ممن جربوا الملف أن يوافونا بعمل الملف من عدمه معهم ..

أخي الحبيب ومعلمي الكبير عادل كل ما تتحدث عنه تقريباً تم التنويه عنه في موضوع التوجيهات ومع اشتراك كل عضو جديد يتم التنبيه عليه بالإطلاع على التوجيهات ولكن لا حياة لمن تنادي نسأل الله العفو والعافية في الدنيا والآخرة أضم صوتي لصوتك وأرجو من الأخوة الأعضاء الالتزام بالتوجيهات تيسيراً على إخوانهم ممن يريدون تقديم المساعدة تقبل تحياتي

الكود يعمل بشكل جيد معي جرب الملف المرفق لربما حدث خطأ أثناء النسخ واللصق Sum Letters YasserKhalil V2.rar

معلمي الحبيب الغالي عادل أنتم الأساس ولنا النبراس ، ومهمااااااااااااااااااا وصلنا فلن ننسى أبداً فضل الله ثم فضلكم علينا .. فأنتم الأعلام في هذا المجال وأنتم من أطلقتم شرارة الإبداع تقبل وافر تقديري واحترامي

جرب التعديل بهذا الشكل Function CalcString(S As String) Dim ArrLetters, ArrValues, X() As Byte, SpaceCounter As Long Dim I As Long, Counter As Long, Pos& ArrLetters = Join(Array("أ", "ا", "إ", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "ة", "و", "ي")) ArrValues = Array(1, 1, 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, 26, 27, 28) X = StrConv(S, vbFromUnicode) For I = 0 To UBound(X) Pos = InStr(ArrLetters, Chr(X(I))) If Pos > 0 Then Counter = Counter + ArrValues((Pos - 1) / 2) Next I On Error Resume Next SpaceCounter = SpaceCount(S) If SpaceCounter = 0 Then CalcString = Counter Else CalcString = Counter - SpaceCounter End If End Function Function SpaceCount(ByVal strLine As String) As String Dim Str As String Dim TempCount As Long Dim I As Long Str = Trim(strLine) TempCount = 0 For I = 1 To Len(Str) If Mid(Str, I, 1) = " " Then TempCount = TempCount + 1 Else If TempCount > 0 Then SpaceCount = SpaceCount & " " & TempCount TempCount = 0 End If End If Next I SpaceCount = Mid(SpaceCount, 2) End Function

هل جربت أن تدخل على التبويب Administrative ثم تقوم بالضغط على Change System Locale ثم تختار اللغة العربية لأي دولة وتعمل ريستارت ..؟؟ لن تخسر شيئاً بالتجربة

بارك الله فيك أخي الحبيب ياسر على حسن استجابتك هكذا يكون العمل .. يسر على إخوانك ييسر الله عليك والشكر موصول لصاحب الكود الأخ الغائب عن العين الحاضر في القلب الأخ الغالي المتميز رجب جاويش تقبلوا تحياتي

أخي الغالي جعفر أخبرتك من قبل أنني سأكون مصدر إزعاج لك جربت الملف على ويندوز 10 نظام 64 بت // أوفيس 2013 64 بت وعدلت في الكود ليناسب نظام 64 ولكن لم يعمل الفورم معي إليك الملف المرفق بعد التعديل API Message Window Jaafar Tribak.rar

بارك الله فيك أخي الغالي ضاحي على الهدية المميزة وكل عام وأنت بخير وتقبل الله منا ومنكم تقبل تحياتي

أخي الكريم قم بالدخول على محرر الأكواد وانظر للحروف العربية وأجبني هل تظهر بشكل سليم أم لا؟ يمكنك تغيير إعدادات اللغة من خلال لوحة التحكم Control Panel ثم الإعدادات الإقليمية Regional & Language وادخل على آخر تبويب Administrative واختر اللغة العربية الجهاز هيطلب منك ريستارت اعمل إعادة تشغيل وجرب الملف مرة أخرى تقبل تحياتي

أخي الكريم محمدجرب تغير السطر بهذا الشكل If Sheets(i).Name <> ActiveSheet.Name And Sheets(i).Name <> "المحاسب" Then جرب الكود بهذا الشكل النهائي Private Sub CommandButton1_Click() Dim I As Long, N As Long, R As Long Range("C13:E41").ClearContents For I = 1 To Sheets.Count If Sheets(I).Name <> ActiveSheet.Name And Sheets(I).Name <> "المحاسب" And Sheets(I).Name <> "احصاء العمر" Then N = Sheets(I).Range("C12").End(xlDown).Row For R = 13 To N If Sheets(I).Cells(R, 4) = [D5] Then With Columns(3).Rows(41).End(xlUp) .Offset(1, 0) = Sheets(I).Cells(R, 3) .Offset(1, 1) = Sheets(I).Cells(R, 4) .Offset(1, 2) = Sheets(I).Cells(R, 5) End With End If Next End If Next End Sub

أخي الكريم جعفر أنا أعمل على نظام التشغيل ويندوز 10 64 بت والأوفيس 2013 64 بت ... إن شاء الله تجد الحل المناسب

وعليكم السلام أخي الغالي عبد العزيز البسكري مشكور على كلماتك الرقيقة في حقي .. بارك الله فيك وجزيت خيراً على مجهودك ونشاطك الملحوظ بالمنتدى أما بالنسبة لموضوع القبعة فلو رفعت القبعة سأضطر أن أرفع أنا أيضاً قبعتي رداً على التحية وهناااااااااااااااا ستحل الكارثة المؤكدة لأنه بمجرد رفع قبعتي ستظهر الفضيحة ويحدث أنعكاس للضوء في عيون كل الناظرين نظراً للصلعة الموجودة في مقدمة الرأس .. تقبل وافر تقديري واحترامي

أخي الحبيب ياسر البنا الملف المرفق غير مطابق للمواصفات الأوفيسنية حيث أنه لا يحتوي على بيانات لتجربة الكود كما أن محرر الأكواد محمي تقبل مخالفتي بصدر رحب ... طبعاً بهزر معاك لتاخد الكلام جد تقبل تحياتي

الأخ الكريم غرب الإكسيل (متخليك شرق عشان تكون معانا) جرب الدالة المعرفة التالية علها تفي بالغرض Function CalcString(S As String) Dim ArrLetters, ArrValues, X() As Byte, SpaceCounter As Long Dim I As Long, Counter As Long, Pos& ArrLetters = Join(Array("أ", "ا", "إ", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "ة", "و", "ي")) ArrValues = Array(1, 1, 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, 26, 27, 28) X = StrConv(S, vbFromUnicode) For I = 0 To UBound(X) Pos = InStr(ArrLetters, Chr(X(I))) If Pos > 0 Then Counter = Counter + ArrValues((Pos - 1) / 2) Next I SpaceCounter = SpaceCount(S) CalcString = Counter - SpaceCounter End Function Function SpaceCount(ByVal strLine As String) As String Dim Str As String Dim TempCount As Long Dim I As Long Str = Trim(strLine) TempCount = 0 For I = 1 To Len(Str) If Mid(Str, I, 1) = " " Then TempCount = TempCount + 1 Else If TempCount > 0 Then SpaceCount = SpaceCount & " " & TempCount TempCount = 0 End If End If Next I SpaceCount = Mid(SpaceCount, 2) End Function وإليك الملف المرفق Sum Letters.rar

الأخ الكريم أبو جنى اعتقدت أن المشكلة قد تم حلها عموماً جرب الملف المرفق التالي .. وإذا قابلتك أي مشكلة قم بالضغط على كلمة Debug وحدد السطر الملون بالأصفر والذي تظهر به المشكلة كما يرجى ذكر إصدار الأوفيس الذي تعمل عليه الملف المرفق مجرب ويعمل بشكل جيد ولا يوجد أي مشاكل ..أنا أعمل على أوفيس 2013 تقبل تحياتي newPDF2.rar

أخي الحبيب أبو جنى لم أقصد بطلبي الإطلاع على التوجيهات أنك أخطأت إنما أحببت أن ترى التوجيهات فقط تغيير اسم الظهور للغة العربية

ممتاز ورائع حقاً أخي الغالي جعفر الآن .. بدأ الفورم يعمل .. عند الشروع في العمل والضغط على زر Start تظهر الضور المقطعة بشكل طبيعي ولكن عند بداية سحب الصور تظهر الصور بخلفية بيضاء وتختفي الصورة ...