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

السلام عليكم إخواني الكرام إليكم الملف المرفق فيه نبذة عن المصفوفات .. أرجو من الله أن ينفع به المسلمين 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

الله ينور تمام جداا كده تسلم ايدك

أخي الحبيب ياسر اعذرني لم ألحظ التغيير الذي تم في الملف .. بارك الله فيك على الإضافة الرائعة

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

تفضل استاذي الفاضل 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 لن يعطيك خطأ بعد الان واعتقد بأنه يريد الذهاب لاخر خلية فيها بيانات فلا جدوى من الذهاب لاخر خلية محددة علما ان اكسل يفتح عندها مباشرة عند انتهاء العمل وعمل حفظ للملف لك كل الاحترام الله يبارك فيك نشرت الحل ولم اجده اعتقد السبب سوء الانترنت عندي وشكرا كتير الك الله يبارك فيك فكتبته مرة ثانية الان وان شاء الله يكون مافيه مشاكل مع انه ممكن تبسيطه اكثر بس الانترنت ينزع المزاج هههههههه الله يعطيكم العافية واكرر شكري لك

اخي محمد اعتقد انه يجب وضع شرط الا تكون الخلية المعنية في أول عامود (و اذ ا كانت كذلك شرط اخر) لأن في هذه الخالة A.Offset(0, -1) تعطينا خطأ

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

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

أخي إبراهيم الأبيض أين الملف المرفق؟ ارفق الملف ومعه كلمة السر ما المقصود بكلمة "أعمل روسات"؟

حاول استبدال الماكرو بهذا (لا توجد اخطاء) 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

ان شاء الله ارفعة لحضرتك وشكرا على ذوقك

أدام الله المحبة والأخوة وجعلك الله دائما سباقا" بالخيرات وتقبل الله منا ومنكم صالح الأعمال

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

الأروع هو تواجدك معنا ونشاطك الجميل والرائع أخي الحبيب وائل إني أحبك في الله

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

تم التعديل استاذ على تفضل aaa.rar

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

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

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

اعمل علاقة بين الجدولين في الاستعلام كما بالصورة

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

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

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

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

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

تفضل استاذ على تم التعديل على المرفق وتغير موضع رسالة التنبيه على عدد الانذارات عند الحفظ وليس عند معاينة التقرير وادخال البيانات من الفورم للجدول مع الاضافة وليس التحديث. أرجو أن يوافى ما تريد aaa.rar

اعزائي هذه مشاركة وبفكرة بالازرار امل ان تنال اعجابكم وتتلخص في : 1. انشاء عدة ازرار اوامر ومن ثم رصها مرتبة وبدون اي تغيير للخصائص : الاكسس 2010 يساعد كثيرا وبنقرة واحدة 2. استخدام دالة واحدة للاضافة وهنا وضعت فقط رسالة لاظهار كود الصنف وبهذا اصبح سهلا العمليات الاخرى 3. تم تغيير خصائص الازرار برمجيا وبالتحديد : خاصية عند النقر لمناداة الدالة .. خاصية التاق لمعرفة كود الصنف .. خاصية العنوان لاظهار اسم الصنف ! هناك فكرة اخرى ولكن تتطلب 2010 ومافوق ! احاول قريبا وباذن الله ! تحياتي للجميع Access_POS.rar

تفضل جرب المرفق وقريبا إن شاء الله حل المشكلة الثانية طلب من اهل الخبرة ف الاكسل2.rar

وعليكم السلام أخي كرار هاي ما كانت سهلة لازم تستخدم الزر اللي في النموذج ، والكود حقه: Private Sub cmd_Combine_Click() 'delete the old data mySQL = "Delete * From tbl_PP" CurrentDb.Execute (mySQL) Dim rstpp As DAO.Recordset Dim rst As DAO.Recordset Set rstpp = CurrentDb.OpenRecordset("Select * From tbl_PP") '1 Set rst = CurrentDb.OpenRecordset("Select * From sh Order By tash") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount 'add all the records For i = 1 To RC rstpp.AddNew rstpp!iDate = rst!tash rstpp!Purchase = rst!mbsh rstpp.Update rst.MoveNext Next i '2 Set rst = CurrentDb.OpenRecordset("Select * From ts Order By tats") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount 'we should check if the date is available, then we should use it For i = 1 To RC rstpp.FindFirst "iDate=#" & rst!tats & "#" If rstpp.NoMatch Then rstpp.AddNew rstpp!iDate = rst!tats rstpp!Payment = rst!mbts rstpp.Update Else rstpp.Edit 'rstpp!iDate = rst!tats rstpp!Payment = rst!mbts rstpp.Update End If rst.MoveNext Next i rstpp.Close: Set rstpp = Nothing rst.Close: Set rst = Nothing DoCmd.OpenQuery "qry_PP" End Sub . وهذه النتيجة: جعفر 231.الرصيد.accdb.zip

السلام عليكم أما الأحرف 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 انتهي عمل الكود

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

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

33 مشاهدة و 8 تحميلات للمرفقات و لا تعليق واحد واضح اننى الوحيد المهتم بهذا الموضوع

الاخ الكريم حماده عمر يسعدنى مررورك وان شاء الله هذا البرنامج يكون اضافه جديده لهذا المنتدى بصفه خاصه وان يكون اضافه لهذا النوع من البرامج بصفه عامه

وجدتها فارغة.rar

السلام عليكم ورحمة الله وبركاته أخواني اسمحوا لي بأن أرفق لكم طريقة اخرى دون اظهار شاشة الاكسس أو استخدام أي ماكرو الطريقة تعتمد : نفتح التقرير في وضع التصميم ونذهب لخصائص التقرير ونجعل 1 - منبثق= نعم 2- شكلي أو مشروط = نعم ننشئ حدث عند الفتح: DoCmd.Maximize نحفظ ثم نغلق التقرير نفتح النموذج في وضع التصميم نذهب لزر تشغيل التقرير ونعدل على الكود تعديلاً بسيط وهو باللون الاحمر ليصبح: On Error GoTo Err_Command3_Click Dim stDocName As String stDocName = "tblImagetable" DoCmd.OpenReport stDocName, acPreview, , , acDialog Exit_Command3_Click: Exit Sub Err_Command3_Click: MsgBox Err.Description Resume Exit_Command3_Click وبعد ذلك نحفظ و نجرب بارك الله فيكم اخواني اعذروني على الاطالة أخوكم : يوسف YM_ShowHideAndReports.rar