hegazee

الحل الأكيد استبدال مربع النص بخلايا

و عليكم السلام حسب فهمي من تنسيق خلايا كما هو موضح بالصورة

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

كما وضح الاستاذ/ عبدالله لا يمكن وضع خانة الرقم في تكست بوكس لأنه سيكون المتحكم في الأشكال الأخرى و هذا غير ممكن في الأكسيل لأنه سيكون مرسل أما أشكال التكست بوكس و هذا ممكن الأخرى فهي مستقبل . أما عن تنزيل الملف فلا أعلم ماهي المشكلة فالملف يعمل بكفاءة. حاول مرة أخرى

كود الاضافة به خطأ اسم ورقة العمل بدلا من s-w مكتوب w-s Private Function SheetExists(sName As String, Optional wb As Workbook) As Boolean Dim sh As Worksheet If wb Is Nothing Then Set wb = ThisWorkbook SheetExists = False For Each sh In wb.Worksheets If sh.Name = sName Then SheetExists = True Exit For End If Next sh End Function Private Sub CommandButton6_Click() Dim wb As Workbook: Set wb = ThisWorkbook Dim inp As Worksheet, s As Worksheet, w As Worksheet If Not SheetExists("s-w", wb) Then MsgBox "ورقة 'w-s' غير موجودة في المصنف الحالي. الرجاء نسخ اسم التبويب كما هو.", vbExclamation Exit Sub End If If Not SheetExists("الصادر", wb) Or Not SheetExists("الوارد", wb) Then MsgBox "تأكد من وجود أوراق 'الصادر' و 'الوارد' أيضاً.", vbExclamation Exit Sub End If Set inp = wb.Worksheets("s-w") Set s = wb.Worksheets("الصادر") Set w = wb.Worksheets("الوارد") Dim lr As Long lr = s.Cells(s.Rows.Count, "A").End(xlUp).Row + 1 ' استخدام الصادر هنا حسب رغبتك With s .Cells(lr, 1).Value = lr - 1 .Cells(lr, 2).Value = inp.Range("E7").Value ' ... بقية الخلايا End With MsgBox "تمت إضافة المعاملة بنجاح", vbInformation End Sub

شكرا استاذ عبدالله و حاولت أن ابتعد عن الأكواد قدر المستطاع و لم يكن هناك خطأ في الصيغة و لكني استخدمت صيغة XLOOKUP و هي ليست متوفرة في الاصدرات القديمة لذلك قمت بتعديل الصيغة ليعمل الملف على أي اصدار تبادل معلوات ورقتين(2).xlsx تبادل معلوات ورقتين(2).zip

تفضل أخي و يمكن اختيار الرقم من قائمة منسدلة تبادل معلوات ورقتين(1).xlsx

الملف يعمل و الكود شغال و دي النتيجة النتيجة

أخي العزيز أين الملف؟

و عليكم السلام ورحمة الله و بركاته استخدم الكود التالي Sub CreateSheetsFromList() Dim ws As Worksheet Dim cell As Range Dim newSheet As Worksheet Dim shName As String ' الورقة اللي فيها الأسماء Set ws = ThisWorkbook.Sheets("Sheet3") ' غير اسم الورقة حسب ملفك ' المرور على العمود A For Each cell In ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) If Trim(cell.Value) <> "" Then shName = Trim(cell.Value) On Error Resume Next ' التأكد إنه مفيش ورقة بنفس الاسم Set newSheet = ThisWorkbook.Sheets(shName) On Error GoTo 0 If newSheet Is Nothing Then ' إنشاء ورقة جديدة بالاسم ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = shName End If Set newSheet = Nothing End If Next cell MsgBox "تم إنشاء الأوراق بنجاح", vbInformation End Sub New.xlsm

و عليكم السلام ورحمة الله و بركاته تفضل =INT((DATEDIF(D13;E13;"y")+DATEDIF(D14;E14;"y")+(DATEDIF(D13;E13;"ym")+DATEDIF(D14;E14;"ym")+(DATEDIF(D13;E13;"md")+DATEDIF(D14;E14;"md"))/30)/12)) & " years; " & MOD(DATEDIF(D13;E13;"ym")+DATEDIF(D14;E14;"ym")+INT((DATEDIF(D13;E13;"md")+DATEDIF(D14;E14;"md"))/30);12) & " months; " & MOD(DATEDIF(D13;E13;"md")+DATEDIF(D14;E14;"md");30) & " days" معادلة طرح وجمع تاريخين 2.xlsx

مرفق شيت به 1000 اختصار لبرنامج الاكسيل لتسهيل العمل منظم حسب الاصدارات للاستاذ/ محمود سيد جزاه الله خيرا 1000 اختصار للاكسيل محمود سيد.xlsx

بارك الله فيك أستاذ أحمد . كما تفضلت حضرتك بالملف فإن معادلة العلامة خبور رائعة و تصلح لهذا الملف تماما فقط قم بنسخ الكود التالي في موديل جديد في في محرر الأكواد Function kh_Names(FullName As String, ParamArray iNdex1()) As String Dim i As Integer Dim kh_Split, MyArray, Ar Dim Kh_String As String, Sn As String, Re As String On Error GoTo Err_Kh_Names '====================================== MyArray = Array("عبد ", "أبو ", "ابو ", "آل " _ , " الله", " الدين", " الإسلام", " الاسلام", " الحق") '====================================== Sn = Application.WorksheetFunction.Trim(FullName) For Each Ar In MyArray Re = Replace(Ar, " ", "^") Sn = Replace(Sn, Ar, Re) Next '====================================== kh_Split = Split(Sn, " ", , vbTextCompare) On Error Resume Next For i = 0 To UBound(iNdex1) Kh_String = Kh_String & " " & kh_Split(iNdex1(i) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") kh_Names = Kh_String Exit Function Err_Kh_Names: kh_Names = "" End Function ثم ضع المعادلة التالية في خانة اسم الأب مثلا: =kh_Names(H9;2;3;4;5) مع مراعاة الفاصلة عادية أو منقوطة حسب اصدار الاوفيس مجمع 2026بعد نتيجة ثالثة.xlsm

السلام عليكم بعد إذنكم جميعا تم حل الموضوع في آخر مشاركة لي في هذا البوست يوم 17 أغسطس و النتائج كما طلب الاستاذ عادل. الآن أين المشكلة؟

تمام كان الخطأ في كود اسم الورقة المفروض يكون www

و عليكم السلام جرب الملف الرقم السري 1234 كود إخفاء واظهار شيتات محددة برقم سري والباقي ظهار 2.xlsm

جرب الملف التالي مع أن حجم البيانات هائل و يستغرق وقت طويل و يستهلك رامات الكمبيوتر 512 صفحة و كل صفحة بها 3 كشوف. الكود يقوم بتصدير الكشوف إلى مجلد على شكل ملفات بي دي اف كل ملف به 3 كشوف و كذلك إنشاء ورقة عمل بالتقسيمات Book2.xlsm

تفضل الملف و جرب كتابة اسماء بها عبد في العمود الثالث و طبق عليها ما تريد حذف المسافات(1).xlsm

وعليكم السلام ورحمة الله و بركاته بعد إذن أستاذنا / حسونه الكود التالي يقوم بعمل اللازم و ضع مسافة بين عبد و أسماء الله الحسنى مثل عبد الله كلمتان و سيكون بعده كود آخر بدون مسافة أي عبدالله مثلا ستكون كلمة واحدة الكود الأول ( عبد الله) Sub CleanSpaces() Dim ws As Worksheet Dim lastRow As Long Dim cell As Range Dim t As String Dim reAbd As Object Dim scr As Boolean, calc As Long Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row scr = Application.ScreenUpdating calc = Application.Calculation Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set reAbd = CreateObject("VBScript.RegExp") With reAbd .Global = True .IgnoreCase = False .Pattern = "عبد(?=[اأإآء-يؤئبةتى])" End With For Each cell In ws.Range("C1:C" & lastRow) If Not cell.HasFormula Then If VarType(cell.Value) = vbString Then t = CStr(cell.Value) t = Replace(t, Chr(160), " ") t = Replace(t, vbTab, " ") t = Replace(t, ChrW(8206), "") t = Replace(t, ChrW(8207), "") t = Application.WorksheetFunction.Trim(t) t = reAbd.Replace(t, "عبد ") t = Application.WorksheetFunction.Trim(t) If cell.Value <> t Then cell.Value = t End If End If Next cell Application.ScreenUpdating = scr Application.Calculation = calc MsgBox "تم تنظيف العمود C ومعالجة 'عبد' .", vbInformation End Sub الود الثاني بدون مسافة: عبدالله Sub CleanSpaces() Dim ws As Worksheet Dim lastRow As Long Dim cell As Range Dim t As String Dim reAbd As Object Dim scr As Boolean, calc As Long Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row scr = Application.ScreenUpdating calc = Application.Calculation Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set reAbd = CreateObject("VBScript.RegExp") With reAbd .Global = True .IgnoreCase = False .Pattern = "عبد\s+(?=[اأإآء-يؤئبةتى])" End With For Each cell In ws.Range("C1:C" & lastRow) If Not cell.HasFormula Then If VarType(cell.Value) = vbString Then t = CStr(cell.Value) t = Replace(t, Chr(160), " ") t = Replace(t, vbTab, " ") t = Replace(t, ChrW(8206), "") t = Replace(t, ChrW(8207), "") t = Trim(t) Do While InStr(t, " ") > 0 t = Replace(t, " ", " ") Loop t = reAbd.Replace(t, "عبد") t = Trim(t) If cell.Value <> t Then cell.Value = t End If End If Next cell ' استرجاع الإعدادات Application.ScreenUpdating = scr Application.Calculation = calc MsgBox "تم تنظيف العمود C بالكامل وإزالة المسافات المكررة والمسافة بعد 'عبد'.", vbInformation End Sub

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

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

تفضل الملف كامل . ما عليك إلا أن تكتب البيانات في صفحات الشهور و سيظهر الفرز تلقائيا في صفحة تم أو غير مسدد 4الحساب.xlsx

و إياكم أخي الكريم

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