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

السلام عليكم إخواني الكرام إليكم الملف المرفق فيه نبذة عن المصفوفات .. أرجو من الله أن ينفع به المسلمين Arrays.rar

السلام عليكم ورحمة الله وبركاته الدرس العاشر 10-InputBox صندوق الإدخال تستخدم InputBox كوسيله لادخال البيانات او للتحقق من بيانات معينه وللتعرف على كيفية استخدامها لابد لنا من التعرف على محتواها InputBox("القيمه الافتراضيه", "العنوان", "النص") مثال على كيفية استخدامها فى ادخال البيانات نريد ادخال اسم hima فى الخليه A3 عن طريق InputBox سيكون شكل الكود كالاتى Sub InputBox_() Dim hima As String 'hima متغير من نوع النصوص hima = InputBox("النص", "العنوان", "hima") ' InputBoxقيمة himaاعطاء المتغير Range("a3") = hima 'InputBox اى himaتساوى قيمة المتغير a3 هنا نقول ان الخليه End If End Sub مثال على كيفية استخدامها فى التحقق من البيانات نريد ادخال اسم hima فى الخليه A3 عن طريق InputBox ونريد ان تظهر لناInputBox نقوم بادخال باسوورد123 كشرط لادخال لظهور InputBox اخرى يتم استخدامها فى ادخال البيانات ولعمل ذلك قم بكتابة الكود الاتى Sub InputBox_1() Dim h As Integer h = 123 'hima متغير من نوع النصوص hima = InputBox("ادخل الرقم السرى", "العنوان") If IsNull(hima) Or hima = "" Then GoTo xx ' xxفى حالة الفراغ يتم الذهاب الى If h = hima Then ' hفى حالة تساوى القيمة المدخله مع المتغير hima1 = InputBox("النص", "العنوان") Range("a3") = hima1 'InputBox اى himaتساوى قيمة المتغير a3 هنا نقول ان الخليه Else xx: MsgBox "كلمة مرور غير صحيحة" & Chr(13) & " الرجاء اعادة ادخال كلمة المرور ", vbOKOnly End If End Sub اتمنى ان يكون الدرس مفيدا مرفق شيت اكسيل به التطبيقات learnvba.rar تقبلوا تحياتى learnvba.rar

أخي الكريم أبو عبد الملك إليك الكود بعد التعديل عله يفي بالغرض (يرجى مراجعة النتائج جيداً ...لأنني لم اختبر الكود بشكل كافي) Sub FollowAll() Dim I As Long, lRow As Long Dim rngFound As Range, Answer Dim wsRecord As Worksheet, wsMonthly As Worksheet, SH As Worksheet Set wsRecord = Sheets("معلومات التسجيل"): Set wsMonthly = Sheets("مجمع النتائج الشهرية"): Set SH = Sheets("كشف متابعة") With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With With wsRecord If MsgBox("هل تريد طباعة كل كشوف الطلبة أم تريد أن تختار طالب معين؟", vbYesNo + vbMsgBoxRtlReading) = vbYes Then For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row If Not IsEmpty(.Cells(I, "N")) Then If MsgBox("الطالب " & .Cells(I, "C") & " منقطع هل تود أن تطبع له كشف?", vbYesNo + vbMsgBoxRtlReading) = vbYes Then GoTo Continue Else End If Else Continue: SH.Range("C1") = .Cells(I, "C") SH.Range("C4") = .Cells(I, "B") SH.Range("C5") = .Cells(I, "A") SH.Range("R5") = .Cells(I, "Q") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(I, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious) If Not rngFound Is Nothing Then lRow = rngFound.Row If wsMonthly.Cells(lRow, "R") >= 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O") ElseIf wsMonthly.Cells(lRow, "R") < 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M") Else MsgBox "لا يوجد درجة للطالب " & .Cells(I, "C"), vbCritical End If End If SH.Range("C2").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))" SH.Range("C3").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$D$2:$D$6))" SH.Range("C2:C3").Value = SH.Range("C2:C3").Value Call CalculateLinesOfRevision SH.PrintPreview End If Next I Else Answer = Application.InputBox("أدخل رقم الطالب بناءً على ورقة معلومات التسجيل", "Input", 1) SH.Range("C1") = .Cells(Answer + 1, "C") SH.Range("C4") = .Cells(Answer + 1, "B") SH.Range("C5") = .Cells(Answer + 1, "A") SH.Range("R5") = .Cells(Answer + 1, "Q") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(Answer + 1, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious) If Not rngFound Is Nothing Then lRow = rngFound.Row If wsMonthly.Cells(lRow, "R") >= 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O") ElseIf wsMonthly.Cells(lRow, "R") < 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M") Else MsgBox "لا يوجد درجة للطالب " & .Cells(Answer + 1, "C"), vbCritical End If End If SH.Range("C2").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))" SH.Range("C3").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$D$2:$D$6))" SH.Range("C2:C3").Value = SH.Range("C2:C3").Value Call CalculateLinesOfRevision SH.PrintPreview End If End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub Private Sub CalculateLinesOfRevision() Dim SH As Worksheet, wsMnhg As Worksheet Dim LRCur As Long, I As Long, II As Long, N As Long, Counter As Long, P As Long Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range Dim X, Y, Z Set SH = Sheets("كشف متابعة"): Set wsMnhg = Sheets("المنهج") With wsMnhg LRCur = .Cells(Rows.Count, 1).End(xlUp).Row Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur) Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur) SH.Range("Q11:Q34").ClearContents X = ValueLookUp(rngB, SH.Cells(4, "R").Value, rngC, rngD, SH.Cells(4, "S").Value, rngA) If X <= 24 Then For I = 2 To X + 1 SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I, "B") & " " & .Cells(I, "D") N = N + 1 Next I Else Y = Application.WorksheetFunction.Ceiling(X / 24, 1) For I = 2 To X + 1 Step Y SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I + Y - 1, "B") & " " & .Cells(I + Y - 1, "D") N = N + 1 Counter = Counter + Y If Y >= X - I Then Exit For Next I If X - Counter > 0 Then SH.Cells(N + 11, "Q") = .Cells(I + Y, "B") & " " & .Cells(I + Y, "C") & " - " & .Cells(X + 1, "B") & " " & .Cells(X + 1, "D") End If SH.Range("O11:O34").ClearContents Z = X - 24 If Z > 0 Then SH.Range("O11:O34") = .Cells(Z, "B") & " " & .Cells(Z, "D") & " - " & SH.Range("R4") & " " & SH.Range("S4") SH.Range("M11:M34,I11:I34,G11:G34").ClearContents P = 1 For II = 11 To 34 SH.Range("M" & II) = .Cells(X + P, "B") & " " & .Cells(X + P, "C") & " - " & .Cells(X + P, "D") SH.Range("I" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 1, "D") SH.Range("G" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 6, "B") & .Cells(X + P + 6, "D") P = P + 1 Next II SH.Range("M11:M34").Copy SH.Range("K11") End With End Sub

أخي الكريم أهلاً ومرحباً بك بين إخوانك بالمنتدي نتمنى قضاء أمتع الأوقات مع إخوانك وأحبابك يرجى تغيير اسم الظهور للغة العربية لمعرفة مزيد من التفاصيل يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة بالمنتدى إليك الملف المرفق عله يفي بالغرض تم إنشاء عدد 2 مربع نصوص TextBox ActiveX Controls تم وضع الكود بهذا الشكل في حدث تغير مربعات النصوص ليؤدي الغرض Private Sub TextBox1_Change() Range("A6:E6").AutoFilter Field:=2, VisibleDropdown:=False Range("A6:E6").AutoFilter Field:=2, Criteria1:="=*" & TextBox1 & "*" End Sub Private Sub TextBox2_Change() Range("A6:E6").AutoFilter Field:=1, VisibleDropdown:=False Range("A6:E6").AutoFilter Field:=1, Criteria1:="=*" & TextBox2 & "*" End Sub Phone Directory.rar

أخي الكريم فضل 1 (أرجو أن تغير رقم 1 في اسم الظهور بلقبك ..) بالنسبة لطلبك ..جرب الدالة المعرفة التالية ... Function IsCountGTE(ByVal Rng As Range) Dim Cnt As Long Dim Data As Variant Dim Item As Variant Application.Volatile Data = Rng.Value If Application.WorksheetFunction.CountIf(Rng, "غ") = 0 Then IsCountGTE = "": Exit Function For Each Item In Data If IsEmpty(Item) Then Cnt = 0 ElseIf Item = "غ" Then Cnt = Cnt + 1 End If If Cnt = 5 Then IsCountGTE = "متتالي" Exit Function End If Next Item IsCountGTE = "غير متتالي" End Function وإليك الملف المرفق يوضح كيفية استخدامها Count Contiguous Cells Only.rar

أشكرك أخى الكريم الأستاذ ياسر خليل على الرد السريع والرائع جزاك الله خيرا ومليار حمد الله على سلامتك

أخي الكريم أحمد مرجان بدايةً يوجد مشكلة بالملف أن العمليات الحسابية يدوي .. قم بالذهاب للتبويب Formulas ثم Caculation Options ثم اختر Automatic طبعاً أنا لم أراجع المعادلة ولكني استنتجت أن هناك خطأ في المدخلات .. قمت بعمل معادلة كالتالي في الخلية N8 ثم سحبها عبر الصف =CLEAN(TRIM(N3)) لكي أقوم بحذف المسافات الزائدة إن وجدت ثم قمت بوضع معادلة أخرى في الخلية N10 ثم سحبها عبر الصف =IF(EXACT(N3,N8),"","Wrong") ثم نظرت في الصف العاشر فوجدت كلمة Wrong في الخلية BO10 فعلمت أن هناك مشكلة في الخلية BO3 .. قم بعمل مسح للخلية من خلال تحديد الخلية ثم الضغط على مفتاح Delete لحذف المحتويات في الخلية . ستجد أن الناتج هو 20 كما توقعت أرجو أن يكون المطلوب

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

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

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

اخي وعليكم السلام اطلع على المرفق فية حل سريع وفكرة بسيطة لعله يحل لك المشكلة تحياتي متتالى وغير متتالى.rar

رائع أخى ياسر العربى نورت المنتدى كدا إسم ياسر بقى منور المنتدى باكثر من عضو وعلى رأسهم الأستاذ القدير / ياسر خليل حفظه الله

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

تفضل اخي هل يفي هذا بالغرض اضغط انتر بعد فتح الفورم واحد سيظهر الفورم اتنين اضغط الزر يظهر الفريم تفعيل الأختصارات في أوامر الفورم.rar

أخي الحبيب يرجى تغيير اسم الظهور للغة العربية إليك الكود التالي عله يفي بالغرض Sub ExportSpecificSheets() Dim ArrSheetToCopy, I As Long If MsgBox("هل تريد نسخ أوراق العمل المحددة إلى مصنف جديد؟", vbYesNo, "NewCopy") = vbNo Then Exit Sub ArrSheetToCopy = Array("التحويل", "المستبعدين") Application.ScreenUpdating = False Application.DisplayAlerts = False With Workbooks.Add For I = (.Sheets.Count + 1) To (UBound(ArrSheetToCopy) + 1) .Sheets.Add Next I For I = 0 To UBound(ArrSheetToCopy) ThisWorkbook.Sheets(ArrSheetToCopy(I)).Cells.Copy With .Sheets(I + 1) .Cells.PasteSpecial xlPasteAll .Cells.Copy .Cells.PasteSpecial xlPasteValues .Name = ThisWorkbook.Sheets(ArrSheetToCopy(I)).Name .DisplayRightToLeft = False .Select: .Range("A1").Select End With Next I .SaveAs ThisWorkbook.Path & "\" & Sheet2.Name & ".xlsm", xlOpenXMLWorkbookMacroEnabled .Close End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub إليك الملف المرفق عله يكون المطلوب تقبل تحياتي Test This File.rar

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

تفضل استاذي الفاضل Private Sub Workbook_Open() Dim a As Range Set a = ActiveCell.SpecialCells(xlLastCell) Private Sub Workbook_Open() Dim a As Range Set a = ActiveCell.SpecialCells(xlLastCell) If a.Address = Range("a1").Address Then Application.Goto a, True Else If a = "" Then r = a.Row c = a.End(xlToLeft).Column Application.Goto Cells(r, c), True Else Application.Goto a, True End If End If End Sub لن يعطيك خطأ بعد الان واعتقد بأنه يريد الذهاب لاخر خلية فيها بيانات فلا جدوى من الذهاب لاخر خلية محددة علما ان اكسل يفتح عندها مباشرة عند انتهاء العمل وعمل حفظ للملف لك كل الاحترام الله يبارك فيك نشرت الحل ولم اجده اعتقد السبب سوء الانترنت عندي وشكرا كتير الك الله يبارك فيك فكتبته مرة ثانية الان وان شاء الله يكون مافيه مشاكل مع انه ممكن تبسيطه اكثر بس الانترنت ينزع المزاج هههههههه الله يعطيكم العافية واكرر شكري لك

السلام عليكم ممتاز استاذ ياسر عمل أكثر من رائع جزاك الله الجنة

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

الله يبارك فيك اخي واستاذي ياسر الحبيب بالنسبة للكود الذي قمت باستخدامه والاستاذ سليم يقوم بالذهاب الى اخر خلية كانت محددة قبل اغلاق اكسل ولكن ليست بالضرورة ان تكون اخر خلية فيها بيانات اما الكود الذي قدمته في مشاركة ثانية يقوم بتحديد اخر خلية فيها بيانات واذا كنت راغبا بعمل سكرول لها يمكنك تعديل الكود السابق الى Application.Goto ActiveCell.SpecialCells(xlLastCell), True تقبل تحياتي واحترامي استاذنا الكريم مع وجود عيب بسيط نادرا ما يحصل سوف اقوم بعمل تجربة لحلها

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

سيد علي السلام عليكم فقط أنا أرجو منك التوضيح أكثر هل تريد جمع سعر المتر لكل مقاس ثم تطرح الخصم أم تريد أخذ مجموع المدفوع كما هو من النموذج الآخر فقط..... على كل حال لقد قمت بالتعديل حسب فهمي وأرجو أن يكون المطلوب كما في المرفق التالي: 1.1023معدل.rar

حاول استبدال الماكرو بهذا (لا توجد اخطاء) Sub copy_every_3() Application.ScreenUpdating = False y = 0 x = Sheets.Count Do While x > 1 Application.DisplayAlerts = False Sheets(x).Delete x = x - 1 Loop Application.DisplayAlerts = True lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row For k = 0 To lr Step 3 Sheets(1).Range("a" & k + 1 & ":a" & k + 3).Copy Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = "list" & Chr(y + 65) ActiveSheet.Range("a1").PasteSpecial (xlValues) ActiveSheet.Columns(1).AutoFit ActiveSheet.Range("a1").Select y = y + 1 Next Sheets("ورقة1").Activate Range("a1").Select Application.CutCopyMode = False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

اذا كنت فهمت المقصود جرب هذا الكود Private Sub Workbook_Open() myaddress = Selection.Address Application.Goto Range(myaddress), True End Sub

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

السلام عليكم ورحمة الله ضع الكود التالي في حدث الصفحة Private Sub Workbook_Open() ActiveCell.SpecialCells(xlLastCell).Select End Sub هذا الكود يمكنك من الانتقال الى اخر خلية فيها بيانات في الصفحة كما يمكنك تحديد فتح صفحة معينة دون غيرها اكتب الكود التالي مع مراعاة كتابة اسم الصفحة الخاص بك Private Sub Workbook_Open() Sheets("add sheets name here").Activate ActiveCell.SpecialCells(xlLastCell).Select End Sub كل الاحترام والتقدير

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

شكرا لك اخي ياسر على التوضيح

ولا اروع بارك الله في علمك

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

كل اللي المفروض يتعمل هو تغيير قيمة الشرط عند اغلاق البرنامج فهو قام بوضع شرط ولم يضع تغييره للاغلاق انه لو وجد الخلية A1 قيمتها 0 يبقي البرنامج مش هيقفل انا ضيفت سطر عند الاغلاق سواء في زر حفظ او عدم حفظ ارجوا ان يكون المراد تجربة2.rar

بارك الله بما وهبك وشكرت الواهب ورزقت برهما..آمين... تقبل تحياتي أبا محمد السلام عليكم.

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

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

تفضل حبيبي الحل تجربة2.rar

اشكركم جدا جدا جدا يااحلى منتدي جزاكم الله كل خير

السلام عليكم عذرا اخي محمد لعدم ايجاد المطلوب ولكن ماذا لو حولت النموذج الى الاكسل ثم وضع كلمة السر عليه ، انا اعمل على اوفيس 2007 لكنت اعملت لك كود تصدير نموذج الى الكسل و كود آخر في الاكسل للتصديره بتنسيق pdf محمي.

بسم الله الرحمن الرحيم الأعضاء الأعزاء أسعد الله أوقاتكم بكل خير فيما يلي الدرس الخامس من دورة "إكسيل 2013 المستوى المتقدم" بعنوان: المصفوفات في اكسيل 2013 الجزء الأول الدرس الخامس - المصفوفات الجزء الأول أتمنى لكم مشاهدة ممتعة ومفيدة يمكنكم تحميل ملفات التمارين الخاصة بهذه الدورة من خلال الرابط التالي: http://www.4shared.com/rar/QvwJQLddce/_-__.html لمتابعة الموضوع الرئيسي للدورة يمكنكم فتح الرابط التالي حيث جميع الدروس موجودة: دورة اكسيل 2013 المستوى المتقدم دمتم بخير أخوكم م/نضال الشامي Google+ Twitter

اتفضلي اختي العزيزة المرفق لعلة يكون فية طلبك تم عمل معادلة لحساب الاجمالي للعام المحدد MyFees بالاضافة للشهر MonthFees اما عن كيفية تشغيلها https://youtu.be/Y5eyL8-5bEY أذا كان مطابق لطلبك برجاء التعليق تم تحياتي Annual fees.rar

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

السلام عليكم أما الأحرف U LR1 W t وغيرها فهي حروف أختارها أنا كما أريد ولكن لابد من إعدائها قيمة وهي تسمى (المتغيرات) وللمزيد من الشرح ادخل على الرابط الآتي http://www.officena.net/ib/topic/56941-افتح-الباب-وادخل-لعالم-البرمجة-متخافوش-يا-أحباب-من-اللي-ورا-الباب/?do=findComment&comment=361289 أما تخصوص RESIZE ادخل على الرابط الآتي http://www.officena.net/ib/topic/56933-الخاصية-resize-في-لغة-البرمجة/?do=findComment&comment=361221 تحياتي

السلام عليكم أخي أبوغازي تفضل الشرح الكود يتكون من جزئين الجزء الأول يتم تنفيذه آليا عند فتح المصنف ووظيفته هي كتابة التاريخ في ثلاثة خلايا وهي C3 , D3 , F3 الموجود في شيت التقرير اليومي وهو كالآتي : Sub Auto_open() يعنى اجعل هذا الكود ينفذ آليا عند فتح المصنف Sheets(2).[d3] = Date اذهب للشيت رقم 2 ( التقرير اليومي ) وضع التاريخ في الخلية D3 Sheets(2).[f3] = "الموافق " & Format(Date, "yyyy/m/d") اذهب للشيت رقم 2 وضع في الخلية F3 كلمة (موافق) وبجانبها التاريخ ولكن بالصيغة المبينة Sheets(2).[c3] = Format(Date, "ddd") اذهب للشيت رقم 2 وضع التاريخ في الخلية C3 ولكن بالكتابة وليس بالرقم ( يعني سبت , أحد وهكذا ) End Sub انهاء الكود الجزء الثاني : يتم فيه ترحيل البيانات من التقرير اليومي إلى شيت اس اف وهو كالآتي : Sub sf() هذا الإجراء قمت أنا بتسميته بـ sf وبإمكانك أن تسميه بما شئت Dim t As Integer, w As Integer, t1 As Integer, t2 As Integer, lr1 As Integer, u As Integer الإعلان عن المتغيرات في هذا الكود lr1 = Application.WorksheetFunction.Count(Sheets(3).Range("B6:B35")) تطلب من الإكسل أن يحسب لك عدد الخلايا التي تحتوى على أرقام في النطاق B6:B35 الموجود في الشيت رقم 3 (اس اف) For u = 6 To lr1 + 6 عمل حلقة تكرارية تبدا من اول سطر في النطاق B6:B35 إلى آخر سطر فيه If Sheets(3).Range("B" & u).Text = Sheets(2).Range("D3").Text Then ابحث في النصوص الموجودة في الشيت رقم 3 في النطاق B6:B35 فعندما يوجد نص مطابق للنص الموجود في الشيت رقم 2 والخلية D3 اعرض هذه الرسالة : لا يمكن الترحيل MsgBox لا يمكن الترحيل"" وهذا يعنى أنه إذا وجد البرنامج التاريخ قد تم إدراجه سابقا فعند الضغط على زر (اس اف) سيقارن الكود هل التاريخ موجود مسبقا أم لا إذا كان موجود يعنى أنه قد تم الترحيل مسبقا فستظهر رسالة : لا يمكن الترحيل وبمعنى آخر أن الترحيل يتم مرة واحدة فقط Exit Sub ثم انهي العمل (هذا إذا كان التاريخ موجودا من السابق) End If Next أما إذا لم يكن التاريخ موجودا فسيكمل الكود عمله كما في الأسفل Sheets(3).Range("B" & 6 + lr1) = Sheets(2).Range("D3").Value اذهب إلى أول خلية فارغة في النطاق B6:B35 الموجود في الشيت رقم 3 (الخاص بأول شركة) وضع فيه التاريخ الموجود في الشيت رقم 2 في الخلية D3 Sheets(3).Range("B" & 43 + lr1) = Sheets(2).Range("D3").Value كرر نفس العمل السابق في النطاق الموجود في الشركة الثانية Sheets(3).Range("B" & 80 + lr1) = Sheets(2).Range("D3").Value كرر نفس العمل السابق في النطاق الموجود في الشركة الثالثة ومعنى هذا أن الكود قام بكتابة التاريخ في كل جدول من الجداول الثلاثة الموجودة في شيت اس اف نأتي الآن إلى نقل القيم من شيت التقرير اليومي (رقم2) إلى شيت اس اف (رقم 3) أولا : الشركة الأولى For t = 6 To 35 عمل حلقة تكرارية تبدأ من السطر رقم 6 إلى السطر رقم 35 وهو الخاص بالشركة الأولى في شيت اس اف If Sheets(3).Range("B" & t) = Sheets(2).Range("D3").Value Then إذا وجدت تاريخ في العمود B الخاص بالشركة الأولى يساوي التاريخ الموجود في الشيت 2 الخلية D3 قم بما يأتي Sheets(3).Range("C" & t) = Sheets(2).[B6].Value انقل القيمة الموجودة في الخلية B6 والشيت 2 إلى العمود C في الخلية المناسبة لها (وهذا يعني انه سينقل الرقم 1) Sheets(3).Range("E" & t).Resize(1, 2) = Sheets(2).[D10].Resize(1, 2).Value انقل القيمتين في الخليتين D10 و E10 إلى المكان الخاص بهما في العمودين E , F (وهذا يعني انه سينقل الرقمين 2 و 3) Sheets(3).Range("G" & t) = Sheets(2).[B11].Value انقل القيمة الموجودة في الخلية B11 والشيت 2 إلى العمود G في الخلية المناسبة لها (وهذا يعني انه سينقل الرقم 4) Sheets(3).Range("H" & t) = Sheets(2).[B13].Value انقل القيمة الموجودة في الخلية B13 والشيت 2 إلى العمود H في الخلية المناسبة لها (وهذا يعني انه سينقل الرقم 5) End If Next ثانيا : الشركة الثانية : بنفس العمل السابق For t1 = 43 To 72 عمل حلقة تكرارية تبدأ من السطر رقم 43 إلى السطر رقم 72 وهو الخاص بالشركة الثانية في شيت اس اف If Sheets(3).Range("B" & t1) = Sheets(2).Range("D3").Value Then Sheets(3).Range("C" & t1) = Sheets(2).[B23].Value Sheets(3).Range("E" & t1).Resize(1, 2) = Sheets(2).[D27].Resize(1, 2).Value Sheets(3).Range("G" & t1) = Sheets(2).[B28].Value Sheets(3).Range("H" & t1) = Sheets(2).[B30].Value End If Next ثالثا : الشركة الثالثة : بنفس العمل السابق For t2 = 80 To 109 عمل حلقة تكرارية تبدأ من السطر رقم 80 إلى السطر رقم 109 وهو الخاص بالشركة الثالثة في شيت اس اف If Sheets(3).Range("B" & t2) = Sheets(2).Range("D3").Value Then Sheets(3).Range("C" & t2) = Sheets(2).[B40].Value Sheets(3).Range("E" & t2).Resize(1, 2) = Sheets(2).[D44].Resize(1, 2).Value Sheets(3).Range("G" & t2) = Sheets(2).[B45].Value Sheets(3).Range("H" & t2) = Sheets(2).[B47].Value End If Next MsgBox "تم الترحيل بنجاح" بعد الانتهاء من الترحيل اعرض هذه الرسالة : تم الترحيل بنجاح End Sub انتهي عمل الكود

تفضل جرب المرفق بعد الانتهاء من التقرير اضغط زر اس اف البرنامج2.rar

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

هذا كان موضوع سابق فى نفس الفكرة المراد تنفيذها جرب و اجبرنا عن النتيجة مرفق ملف يستخدم ايضاً فى نفس الموضوع بس حمل الخط على الجهاز اولاً http://www.officena.net/ib/index.php?showtopic=10213 Excel Example.rar

السلام عليكم و رحمة الله و بركاته الاخوة الاحباب بالمنتدى عن طريق ملف الاكسل المرفق يمكنك عمل بحث فى جهازك عن اي ملف عن طريق الاكسل و قمت بعمل واجهتين عربية و انجليزية و اضافة Hyperlink ( ارتباط تشعبي ) لسهولة الوصول للملفات التي تم البحث عنها كما يمكنك اختيار او كتابة الدرايف او المسار الذي سيتم البحث فيه و اختيار الامتداد او اسم الملف الذي سيتم البحث عنه و أسأل الله العلى العظيم أن ينفعكم بهذا العمل و الله و الموفق و المستعان و السلام عليكم و رحمة الله و بركاته SEARCH HaNcOcK.rar

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

أخي العزيز بدل البحث عن الموضوع السابق، و الدخول بتعقيدات إختلاف الحاجات ،، قمت بإنشاء تطبيق سريع أظن أنه سيفي بحاجتك. النقطة الرئيسية تعتمد على أن التقارير لا تظهر إلا من خلال نافذة الأكسيس ، لذا لا بد من الوصول لهذه النقطة ببعض الذكاء و التلاعب البرمجي Manipulation . نقوم بجعل النماذج والتقارير Pop Up. ننشيئ ماكرو للإخفاء وماكرو للإظهار ننشيئ وحدة نمطية للسيطرة نوزع عمليات تشغيل الماكرو حسب الحاجة ، ووفقا للشرط الرئيسي أعلاه (إظهار نافذة الأكسيس للتقارير) وذلك بين النماذج والتقارير المرفق أظن أنه يفي بالغرض .... أو على الأقل يوصل الفكرة الرئيسية .... ,ولم أقصد به تطبيقا متكاملا فهو يحتاج للضبط وإكثار تجربة الإحتمالات لسد الثغرات والله أعلم تفضل .......... ............ NA_ShowHideAndReports.rar

اخي : رضا التنسيق المخصص بالثلاثة فواصل المنقوطه يخفي كل ما تدخله بالخلية سواءا ارقام او حروف (وليست الارقام فقط) والسائل يريد ان يرى الكتابة وهي بالخلية والا يراها اثناء المعاينه قبل الطباعة ، وايضا عند الطباعة.

بسم الله الرحمن الرحيم هذا أول وبرنامج وسوف تجد به التالي 1- شؤون الأيتام أ- شاشة أيتام غير مكفولين ب - أحصائية الأيتام ج - أيتام لم يستلموا أستحقاقاتهم د - أيتام أستلموا أستحقاقاتهم هـ - أضافة يتيم و - أستلامات يتيم 2- شؤون الكفلاء أ - شاشة الكفلاء وأيتامهم ب - شاشة أضافة كفيل ج - شاشة أضافة وسيط د - شاشة الوسطاء وكفلائهم 3- الشؤون المالية أ - شاشة صرف ب - شاشة أستلام ج - شاشة الأرصدة د - شاشة الكشف العام و - شاشة كشف كفيل هـ - شاشة كشف يتيم 4- الخدمات 5- دليل هاتف 6- نموذج لتسجيل المواعيد 7- نموذج لأظافة البنوك 8- شؤون الموظفين والكثير مما لا يتسع المجال لذكره تمعن في هذا البرنامج وأذا رغبت في تعديل أي شئي فالجميع سوف يقوم بخدمتك والله نسأل أن يجعلها لنا في موازيننا يوم لا ينفع لا مال ولا بنون وتقبل تحياتي وسوف أبحث لك عن غيره وأضيفه لك أخيك سهل أحمد ( ابو نعيم ) Aytam.rar