نجوم المشاركات

السلام عليكم ورحمة الله تعالى وبركاته اقدم لكم هذا الفورم البسيط للترحيل في العمود A مثلا وهذا بفضل أساتذتي الكرام في هذا الصرح العظيم أكواد الترحيل 1 Dim ws As Worksheet Dim lr As Long '--------------------------------------------- Set ws = ThisWorkbook.Sheets(1) '--------------------------------------------- lr = ws.Cells(Rows.Count, "A").End(xlUp).Row ws.Cells(lr + 1, 1) = Me.TextBox1.Text '--------------------------------------------- 2 Dim ws As Worksheet Dim lr As Long '--------------------------------------------- Set ws = ThisWorkbook.Sheets(1) '--------------------------------------------- lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 ws.Cells(lr, 1) = Me.TextBox1.Text '--------------------------------------------- 3 Dim ws As Worksheet Dim lr As Long '--------------------------------------------- Set ws = ThisWorkbook.Sheets(1) '--------------------------------------------- lr = Range("A65536").End(xlUp).Row ws.Cells(lr + 1, 1) = Me.TextBox1.Text '--------------------------------------------- 4 Dim ws As Worksheet Dim lr As Long '--------------------------------------------- Set ws = ThisWorkbook.Sheets(1) '--------------------------------------------- lr = Range("A65536").End(xlUp).Row + 1 ws.Cells(lr, 1) = Me.TextBox1.Text '--------------------------------------------- 5 Dim ws As Worksheet Dim lr As Long '--------------------------------------------- Set ws = ThisWorkbook.Sheets(1) '--------------------------------------------- lr = ws.Cells(Rows.Count, 1).End(xlUp).Row - 1 ws.Cells(lr + 2, 1) = Me.TextBox1.Text 6 Dim ws As Worksheet Dim lr As Long '--------------------------------------------- Set ws = ThisWorkbook.Sheets(1) '--------------------------------------------- lr = Cells(Rows.Count, "A").End(xlUp).Row - 1 ws.Cells(lr + 2, 1) = Me.TextBox1.Text '--------------------------------------------- وفي الأخير ملف مع التجميعية اتمنى ان تفيدكم خاصة للمبتدئين الترحيل من الفورم للشيت بعدة طرق.rar

شاهد الصورة

في خصائص الفورم الخاصية RightToLeft غير قيمتها True او عن طريق الكود في حدث UserForm_Initialize Private Sub UserForm_Initialize() With UserForm2 .RightToLeft = True End With End Sub او كود مختصر Private Sub UserForm_Initialize() Me.RightToLeft = True End Sub

اخى الكريم المقصود ب DADA هو المعلومات اللى بالست بوكس واللست بوكس ياتى بالمعلومات من اى تغيير على TextBox4 اللى هو البحث بمجرد كتابة حرف فى TextBox4 اللى هو البحث يتم جلب كل المعلومات من الجدول المطابقه للبحث المعلومات اللى تم جلبها دى بقى اسمها DADA يتم تعريفها بهذا الاسم ودى الجزئية اللى بالكود الخاصه بجلب البيانات الى الست بوكس ثم تعريف هذه البيانات باسم DADA Set AL_2 = Sheets("ورقة1") With AL_2 LastRow = .Cells(.Rows.Count, "b").End(xlUp).Row Set q = .Range("b3:b" & LastRow).Find(M) If Not q Is Nothing Then F = q.Address Do If Application.WorksheetFunction.Search(M, q, 1) = 1 Then ListBox1.AddItem q.Value ListBox1.List(V, 1) = q.Offset(0, -1).Value ListBox1.List(V, 2) = q.Offset(0, 1).Value ListBox1.List(V, 3) = q.Offset(0, 2).Value ListBox1.List(V, 4) = q.Address V = V + 1 End If Set q = .Range("b3:b" & LastRow).FindNext(q) Loop While Not q Is Nothing And q.Address <> F End If End With ودى الجزئية الخاصه بتعريف DaDA DADA = ListBox1.List(ListBox1.ListIndex, 4) Set MYSH = Sheets("ورقة1") With MYSH .Application.Range(DADA).Activate .Range(DADA).Value = TextBox2.Text '.Range(DADA).Offset(0, -1).Value = TextBox1.Value .Range(DADA).Offset(0, 1).Value = TextBox3.Value End With اتمنى ان اكون وفقت بالشرح تقبل تحياتى

وعليكم السلام عليكم ورحمة الله وبركاته هلا ماجد جرب جميع الازرار في المرفق LISTBOX.zip

أخي الكريم تفضل ما طلبته أولا قم بإنشاء زر تحكم وسمه مثلا cmd_1 وفي حدث الزر قم بإدراج الكود التالي Private Sub cmd_1_Click() With UserForm1 .Height = 380.25 .Left = 0 .Top = 2.25 .Width = 448.5 .Zoom = 100 .StartUpPosition = 2 - CenterOwner End With

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'sex جنس العملة " 'FALSE ( فارغ او صفر مذكر ) " 'TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'sNameCurr اسم العملة الرئيسية مفرد " 'pNameCurr اسم العملة الرئيسية جمع " 'NameCurrDec اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- 'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة Private Const MyBegTx As String = "فقط " ' "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String Dim Td$, Td1$ On Error GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar ================================================= الملف المعدل: هذا المرفق بامكانية تفقيط الكسر وامكانية ادخال كلمة نهاية النص دالة تحويل الرقم الى نص عربي.rar ================================================= رابط مباشر للملف

السلام عليكم هل هناك برنامج نظام مستخدمين للتواصل مع المستخدمين كتابة أو صوت بحيث يكون أكثر شمولية من نظام المستخدمين المعروف وجزاكم الله خيرا

تفضل أخي كما اردت تحكم بحجم الفورم تم التعديل.rar

طيب نخليها كده على شانك Range("A1", ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell)).Select

تفضل أخي الكريم الملف التالي Transfer Data According To Date.rar

شكرا اخي الفاضل ابو خليل علي الرد جزاك الله خير الجزاء

تم تعديل العنوان

بسم الله ما شاء الله عمل اكثر من رائع جعله الله في ميزان حسناتك

بارك الله فيك اخي الجموعي و جزاك الله خيرا عن كل حرف كتبت

روعة أخي الحبيب اجموعي هو دا الشغل اللي بجد ..فيد واستفيد بارك الله فيك وجزاك الله خير الجزاء

بارك الله فيك أستاذي على هذا الكود الرائع إستفدت منه الكثير جعله الله في موازين حسناتك تحياتي لك

معذرة مني أخي الكريم لم أنتبه لردك شكرا وبارك الله فيك

تفضل اخي

شكرا لك اخي الكريم وبارك الله في عمرك ومالك واهلك ان شاء الله تعالى

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

السلام عليكم فكرة جميلة

اخي ياسر كود جميل وحان الوقت كي اكشف انا عن الكود يتاعي merge unmerge.rar

تفضل اخوي احمد تم تعديل خصائص الصلة في العلاقات ان اردت الاستجابة السريعة في الرد من اخوانك فاجعل امثلتك في المرات القادمة على صيغة mdb برنامج المرتبات2.rar

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

تفضل مطلوبك db.rar

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

تفضل التعديل تم توظيف الأداة if في حدث تنسيق التفصيل Database11.rar

اليك مثال لاخفاء عمود بناء على قيمة فى خليه اذا كانت القيمة اكبر من 180 يتم الاخفاء Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range("A2").Value > 180 Then Columns("D").EntireColumn.Hidden = True End If End Sub ضع الكود فى حدث الورقة مع تحياتى اخفاء عمود بناء على قيمة خليه.rar

السلام عليكم حسب مصدر القوائم لا داعي استخدام دالة Dlookup و يمكن الحل بالطريقة كما هو في المرفق بالتوفيق,, accouting.rar

شكرا على المجهود

أخى فى الله الأستاذ القدير // ابراهيم ابو ليله بارك الله فيكم وزادكم الله من فضله ومن علمه وأؤيد مطلب الأستاذ الكبير // محمد الريفى وهذا تبعا لوقتكم جعله الله فى ميزان حسناتكم تقبل منى وافر الاحترام والتقدير

أخى الفاضل / قصى البرنامج يعمل على أوفيس 2010 أو 2013 وقد نفذته على أوفيس 2010 بناءا على طلب كثير من الأخوة الزملاء

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

السلام عليكم هذا الكود ليس من اعمالي وانما استخدمته كثيرا في اعمالي ملحوظة: يكفي هذا السطر من الكود ليقوم بذلك Sub SheetList_CP() Application.CommandBars("Workbook Tabs").ShowPopup End Sub تحياتي

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

اخي المعادلة التي ذكرت ( Vlook on) هي معادلة معرفة وغير موجود ضمن دوال اي نسخة من الاوفيس يمكنك نسخ كود الدالة ووضعه في موديول في محرر الاكواد وستعمل الدالة .