أ / محمد صالح

أخي الكريم
الحمد لله لي السبق في هذا المجال الترجمة بالكود في vba
وغيرت الكود مرة في 2017 ومرة في 2019 ولم أهتم بعدها بهذه الطريقة
وبالنسبة لملفكم
بالنسبة للرابط المستععمل قي الكود فهو خاص بنسخة الموبايل
https://translate.google.com/m?sl=auto&tl=ar&hl=en-US&q=Good+morning
ولا يوجد به زر للنطق والكود يستعمل زر له كلاس
.Document.QuerySelector(".VfPpkd-Bz112c-kBDsod-OWXEXe-IT5dJd").Click وهو غير موجود
وبالنسبة لطلب صفحة الترجمة الكاملة
فالنطق يكون غير مدعوم في متصفح انترنت اكسبلورر المستخدم في الكود
Voice output isn't supported on this browser
خلاصة الكلام: أن هذه الطريقة لنطق النص أصبحت غير متاحة
وكنت قد أوضحت أنه يوجد طريقة أخرى أستعملها في موقعي الشخصي mr-mas.com
ولكن لم أحولها إلى vba لانشغالي هذه الفترة ولاني مستاء جدا من نشر أكوادي باسم غيري فلا يوجد في مصر والعالم العربي ما يسمى بالأمانة العلمية
ربما لاحقا أحول هذه الطريقة إلى vba
بالتوفيق

أخي الكريم
الحمد لله لي السبق في هذا المجال الترجمة بالكود في vba
وغيرت الكود مرة في 2017 ومرة في 2019 ولم أهتم بعدها بهذه الطريقة
وبالنسبة لملفكم
بالنسبة للرابط المستععمل قي الكود فهو خاص بنسخة الموبايل
https://translate.google.com/m?sl=auto&tl=ar&hl=en-US&q=Good+morning
ولا يوجد به زر للنطق والكود يستعمل زر له كلاس
.Document.QuerySelector(".VfPpkd-Bz112c-kBDsod-OWXEXe-IT5dJd").Click وهو غير موجود
وبالنسبة لطلب صفحة الترجمة الكاملة
فالنطق يكون غير مدعوم في متصفح انترنت اكسبلورر المستخدم في الكود
Voice output isn't supported on this browser
خلاصة الكلام: أن هذه الطريقة لنطق النص أصبحت غير متاحة
وكنت قد أوضحت أنه يوجد طريقة أخرى أستعملها في موقعي الشخصي mr-mas.com
ولكن لم أحولها إلى vba لانشغالي هذه الفترة ولاني مستاء جدا من نشر أكوادي باسم غيري فلا يوجد في مصر والعالم العربي ما يسمى بالأمانة العلمية
ربما لاحقا أحول هذه الطريقة إلى vba
بالتوفيق

يمكنك استعمال هذه الدالة لتحويل النص العربي من رموز غريبة إلى utf8
وذلك بإضافة هذا الكود في موديول جديد في شاشة الفيجوال بيسك للتطبيقات vba
بالضغط على alt+f11 ثم من قائمة insert نختار module ثم نلصق هذا الكود
Function masAr2Utf(inputStr As String) As String Dim n As Integer, i As Integer, inBytes() As Byte, sUnicode As String n = Len(inputStr) ReDim inBytes(n + 1) For i = 1 To n inBytes(i) = AscB(Mid(inputStr, i, 1)) Next sUnicode = StrConv(inBytes, vbUnicode, &H401) iPos = InStr(sUnicode, Chr(0)) If iPos > 0 Then sUnicode = Mid(sUnicode, iPos + 1) masAr2Utf = sUnicode End Function وطريقة استدعائها في الشيت
نكتب في الخلية المراد ظهور النص العربي بها
=masAr2Utf(B2) بالتوفيق

عليكم السلام ورحمة الله وبركاته
يمكنك استعمال هذا الكود في حدث عند التغيير
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$G$2" Then Call ter End If End Sub كلك يمين على اسم الشيت ثم view code ثم لصق في الناحية اليمنى
بالتوفيق

يمكنك استعمال دالة offset
Sub offsetplus() ActiveCell.Value = ActiveCell.Offset(0, -3).Value + 3 End Sub مع ملاحظة 0 تعني في نفس الصف
رقم -3 تعني الخلية الثالثة السابقة
رقم +3 تعني الرقم الذي يتم إضافته
بالتوفيق

بعد إذن حبيبنا @omar elhosseini
يمكنك استعمال هذه الأكواد في صفحة Rooming list
كلك يمين ثم view code ثم تلصق هذا الكود
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Or Target.Row <= 2 Then Exit Sub If Target.Column = 3 And Target.Value <> "" And Not (sheetExists(Target.Value)) Then Call newsh(Target.Value) End If End Sub Function sheetExists(sheetToFind As String) As Boolean sheetExists = False For Each Sheet In Worksheets If sheetToFind = Sheet.Name Then sheetExists = True Exit Function End If Next Sheet End Function Sub newsh(newname As String) OptimizeVBA 1 Sheets("Aqua Park HRG").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = newname ActiveSheet.Range("K2") = newname OptimizeVBA 0 End Sub Sub OptimizeVBA(isOn As Boolean) Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic) Application.EnableEvents = Not (isOn) Application.ScreenUpdating = Not (isOn) ActiveSheet.DisplayPageBreaks = Not (isOn) End Sub وبه من كنوز مكتبتي الخاصة الكثير من التحف
التأكد من وجود اسم الشيت
تحسين سرعة الأكواد في vba
بالتوفيق

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

لا أعتقد أن هذا يتم بمعادلة
يمكنك استعمال هذا الكود في حدث تغيير الشيت
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column > 1 And Target.Column < 6 Then Range("f" & Target.Row) = Date End Sub كلك يمين على اسم الشيت ثم view code
ثم لصق هذا الكود في الناحية اليمنى
مع حفظ الملف بامتداد يدعم الأكواد مثل xls أو xlsb أو xlsm
بالتوفيق

لا أعتقد أن هذا يتم بمعادلة
يمكنك استعمال هذا الكود في حدث تغيير الشيت
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column > 1 And Target.Column < 6 Then Range("f" & Target.Row) = Date End Sub كلك يمين على اسم الشيت ثم view code
ثم لصق هذا الكود في الناحية اليمنى
مع حفظ الملف بامتداد يدعم الأكواد مثل xls أو xlsb أو xlsm
بالتوفيق

مشكلة عدم ظهور أحد في صفحة كل معلم على حدى
يرجع إلى عدم دقة معادلة الفلتر
جرب استعمال هذه المعادلة في الخلية D9
=IFERROR(INDEX(sheet2!B$4:B$300,SMALL(IF(sheet2!$AK$4:$AK$300=$J$1,ROW(sheet2!B$4:B$300)),ROW($D1))),"") ويمكنك سحبها يسارا ولأسفل
مع مراعاة بداية ونهاية النطاقات في مثل هذه المعادلات
ويمكن تحويلها إلى كود بأكثر من طريقة
أسهلها أن تضع المعادلة في النطاق بالكود
مثلا
range("d9:d28").formulaarray = "=IFERROR(INDEX(sheet2!B$4:B$300,SMALL(IF(sheet2!$AK$4:$AK$300=$J$1,ROW(sheet2!B$4:B$300)),ROW()-8)),"""")" ثم تحول ناتج المعادلة إلى قيم بهذا الكود
range("d9:d28").value = range("d9:d28").value وهكذا مع كل نطاق له معادلة مختلفة
 
وأقترح أن تربط ذلك بتغيير الخلية J1
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$1" Then Range("d9:d28").FormulaArray = "=IFERROR(INDEX(sheet2!B$4:B$300,SMALL(IF(sheet2!$AK$4:$AK$300=$J$1,ROW(sheet2!B$4:B$300)),ROW()-8)),"""")" Range("d9:d28").Value = Range("d9:d28").Value MsgBox "Done by mr-mas.com" End If End Sub مع تكرار السطرين الثالث والرابع مع كل نطاق له معادلة محتلفة
رغم أني لا أميل أبدا إلى موضوع تحويل المعادلات إلى أكواد فهذا يستهلك موارد الجهاز  فيما لا يفيد المستخدم
ولا يحمي المعادلات
بالتوفيق

أقترح تنفيذ ذلك يدويا وليس بالكود
عن طريق عمل لصق كقيم paste as values بدلا من لصق paste 
ورمزها (123) في القائمة المختصرة للخلية والتي تظهر بعد عمل كلك يمين عليها

وإذا كنت حريصا على استخدام الكود فيمكنك وضع هذا الاجراء في موديول جديد وربطه بزر وليكن اسمه لصق
Sub pst Selection.PasteSpecial Paste:=xlPasteValues End Sub وهو للصق ما تم نسخه في الخلية المحددة
ولاستخدام هذا الاجراء عند الضغط على CTRL+V يمكن وضع هذا الكود في حدث المصنف ThisWorkbook
Private Sub Workbook_Activate() Application.OnKey "^v", "pst" End Sub Private Sub Workbook_Deactivate() Application.OnKey "^v" End Sub بهذه الطريقة تحافظ على تنسيق الملف الذي يتم اللصق فيه 
عند استخدام الزر المرتبط بالكود أو اللصق باستخدام ctrl+v
بالتوفيق

هذا ملف يحتوي على تصميم شكل النتيجة فقط
أين محاولاتك للوصول للمطلوب؟ وما المشكلة التب واجهتك في تنفيذ مطلوبك؟
أم أنك تريد الحصول على برنامج جاهز لهذا الغرض؟؟؟
 

حسب فهمي للمطلوب يمكن تغيير إجراء تحميل القائمة إلى
Sub loadlistbox() Set ws = ThisWorkbook.Sheets("SoldFeedbags") Set rData = ws.Range("A1").CurrentRegion irow = Application.WorksheetFunction.CountA(ws.Range("A:A")) If irow = 1 Then irow = 2 Me.TextBox8.Value = Evaluate("sum(SoldFeedbags!e2:e" & irow & ")") Me.TextBox9.Value = Evaluate("sum(SoldFeedbags!f2:f" & irow & ")") Me.TextBox10.Value = Evaluate("sum(SoldFeedbags!g2:g" & irow & ")") With Me.ListBox1 .RowSource = "SoldFeedbags!A2:I2" .RowSource = "SoldFeedbags!A2:I" & irow .ColumnCount = rData.Columns.Count .ColumnHeads = True .ColumnWidths = "60,70,70,70,70,60,70,60,70" End With End Sub بالتوفيق

ممكن التنسيق الشرطي
يلون الخلايا المكررة
وبعدها يحذف المستخدم هذا التكرار

يمكنك استعمال خاصية البحث المضمنة داخل الاكسل
بالضغط على CTRL+F

أقترح عليك عمل شيتين للبيانات وشيت للتقرير
الأول للدائنين وبه:
الرقم والاسم المبلغ وتاريخ الاقتراض وأي ملاحظات
والثاني للتسديدات وبه:
رقم الدائن المبلغ المسدد تاريخ التسديد المستلم وأي ملاحظات أخرى
والثالث لعرض التقرير الخاص بأحد الدائنين بدلالة رقم الدائن
وتستعمل به معادلات البحث
بالتوفيق

جرب استعمال هذا الكود 
كمحاولة لضبط المدخلات في الخلايا عن طريق الاستبدال
ثم بعدها يتم تقسيم النص إلى أعمدة عن طريق الشرطة يدويا
ويمكنك إضافة أي عدد من العناصر التي يمكن استبدالها في المصفوفتين
Sub mrmas() OldArr = Array("مهندس", "معاون", "درجة", "سادسة", "خامسة", "رابعة", "ثالثة", "ثانية", "اولى", "كبير", "استثنائى", "كبير-ثان", "كبير -ثان", " ", "--") newarr = Array("-مهندس", "-معاون", "-درجة", "سادسة-", "خامسة-", "رابعة-", "ثالثة-", "ثانية-", "اولى-", "كبير-", "-استثنائى-", "كبير ثان", "كبير ثان", " ", "-") For r = 1 To Cells(Rows.Count, 1).End(xlUp).Row For i = 0 To UBound(OldArr) Range("a" & r).Value = Trim(Replace(Range("a" & r).Value, OldArr(i), newarr(i))) Next i Next r MsgBox "Done by mr-mas.com" End Sub وهذا الملف وبه الكود لأنه في بعض الحالات لا يعرف صاحب الاستفسار طريقة إضافة الكود ..بالتوفيق
تقسيم النص إلى معلومات.xlsb

حسب فهمي للمطلوب
حضرتك تريد طريقة لتخطي رسائل الأمان
1- الخاصة بتمكين التعديل وهذه حلها ألا يتم تحميل ملف اكسل من الانترنت مباشرة بل يتم تحميل ملف مضغوط RAR مثلا ثم يفك الضغط عنه ليحصل على ملف الاكسل
2- أما الرسالة الخاصة بتمكين المحتوى فلا يمكن تخطيها ويجب موافقة المستخدم على تشغيل الأكواد الموجودة في الملف وهذا آخر ما توصلت إليه ميكروسوفت في تأمين مستخدميها
وتذكر دائما أنه لا يوجد حماية مطلقة بل يوجد حماية لا يعرف التعامل معها أحد المستخدمين
أتمنى أن يكون الأمر اتضح
بالتوفيق

هذا الأمر تكرر كثيرا
يمكنك الاستفادة من هذه المواضيع
بالتوفيق
 

هذا الأمر تكرر كثيرا
يمكنك الاستفادة من هذه المواضيع
بالتوفيق
 

هذا الأمر تكرر كثيرا
يمكنك الاستفادة من هذه المواضيع
بالتوفيق
 

عليكم السلام ورحمة الله وبركاته
للحصول على الاسم الأول يمكنك استعمال هذه المعادلة
=LEFT(N14,FIND(" ",N14)-1) وللحصول على الاسم الأخير يمكنك استعمال هذه المعادلة
=RIGHT(N14,LEN(N14)-FIND("*",SUBSTITUTE(N14," ","*",LEN(N14)-LEN(SUBSTITUTE(N14," ",""))))) تم تدمج الحلايا الثلاث في خلية واحدة
التي بها الرقم والاسم الأول والاسم الأخير
=aj1&" "&aj2&" "&aj3 وتكون هذه هي خلية اسم الشيت
بالتوفيق

يمكنك استعمال هذه المعادلة في الخلية D3
=IF(OR(A3=0,A3=""),"",C3-22) بالتوفيق

عليكم السلام ورحمة الله وبركاته
يمكنك استعمال هذه المعادلة في الخلية B2 وسحبها يمينا ثم أسفل
=IF(AND(B$1>=main!$B3,B$1<=main!$C3),B$1,"") وتعني إذا كان التاريخ المكتوب في B1 أكبر من أو يساوي تاريخ بداية المدة وأقل من أو يساوي تاريخ نهاية المدة يتم كتابة هذا التاريخ وإلا تظهر الخلية فارغة
مع تغيير تنسيق الخلايا إلى تاريخ
بالتوفيق

تمت الإجابة عن شيء مثل هذا
بالتوفيق