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

مبروك الأستاذ lionheart إنضمامك لعائلة الخبراء ,أسأل الله لك التوفيق والنجاح دائما ..وأعانك الله على هذه المسئولية الجديدة وسدد الله خطاك عن حق وجدارة بارك الله فيك وزادك الله من فضله

يمكنك إضافة العمود c في الترتيب المطلوب هنا تم اعتباره المستوى الثالث للترتيب Sub a_b() Application.GoTo Reference:="sheet" Selection.Sort Key1:=Range("E7"), Order1:=xlAscending, Key2:=Range("F7") _ , Order2:=xlAscending, Key3:=Range("c7"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ :=xlSortNormal, DataOption3:=xlSortNormal Range("A1").Select End Sub لاحظ إضافة key و order و dataoption لكل مستوى فرز بالتوفيق

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

يمكنك استعمال هذا الاجراء Sub tr7eel() For r = 4 To Cells(Rows.Count, 2).End(3).Row r2 = Evaluate("=MATCH(B" & r & ",'الدور الثانى'!B:B,0)") c2 = Evaluate("=MATCH(C" & r & ",'الدور الثانى'!3:3,0)") Sheet2.Cells(r2, c2) = Range("d" & r) Next r MsgBox "Done by mr-mas.com" End Sub بالتوفيق

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, dic As Object, s As String, t As String, i As Long, c As Long Set ws = ThisWorkbook.Worksheets(1): Set sh = ThisWorkbook.Worksheets(2) Set dic = CreateObject("Scripting.Dictionary") a = ws.Range("A3").CurrentRegion.Value For i = LBound(a) + 1 To UBound(a) s = a(i, 2) & Chr(2) & a(i, 3) If Not dic.Exists(a(i, 1)) Then dic.Add s, a(i, 4) Next i For i = 2 To sh.Cells(Rows.Count, "B").End(xlUp).Row For c = 3 To 8 t = sh.Cells(i, 2).Value & Chr(2) & sh.Cells(3, c).Value If dic.Exists(t) Then sh.Cells(i, c).Value = dic(t) Next c Next i End Sub

ما معنى اقوى ... حقيقة لم افهمك جيدا كما اني ارى في vb حرية حركة ومرونة عالية في كتابة الكود وهناك اكواد لا يمكن كتابتها في الماكرو لذلك افضل vb والاهم ان يكون الناتج صحيح مهما اختلفت الطرق تحياتي

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

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

Congratulations, he deserves it for sure.

@hassansaat تعلم الاستيراد بكل سهولة في البداية قم بإستدعاء مكتبة الإكسل الآن نقوم بإنشاء Module جديد و اضافة الكود التالي Public filenname As String Public Function importExcel(tablename As String) As String ', filenname As String Dim xlApp As Excel.Application Dim xlWb As Excel.Workbook Dim xlWs As Excel.Worksheet Dim intLine As Long Dim strSqlDml As String Dim strColumn1 As String, strColumn2 As String, strColumn3 As String varfile = filenname CurrentDb.Execute "DELETE * FROM List", dbFailOnError Set xlApp = New Excel.Application xlApp.Visible = False Set xlWb = xlApp.Workbooks.Open(varfile) Set xlWs = xlWb.Worksheets(1) intLine = 2 Do strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) strSqlDml = "INSERT INTO List VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')" CurrentDb.Execute strSqlDml, dbFailOnError xlWs.Cells(intLine, 1).Select intLine = intLine + 1 Loop Until IsEmpty(xlWs.Cells(intLine, 1)) xlWb.Close False xlApp.Quit Set xlApp = Nothing Set xlWb = Nothing Set xlWs = Nothing filenname = "" End Function Public Sub SelectFiles() Dim Addfile As Object Set Addfile = Application.FileDialog(3) With Addfile .AllowMultiSelect = False .InitialFileName = "" .Filters.Clear .Filters.Add "Excel Files", "*.xls,*.xlsx" If .Show = True Then filenname = Trim(.SelectedItems(1)) Else Exit Sub End If End With End Sub شرح مختصر للكود نقوم بالإعلان عن متغييرات تحمل اسماء مستعارة للأعمدة في ملف الإكسل مثلا strColumn1 -strColumn2 - strColumn3 Dim strColumn1 As String, strColumn2 As String, strColumn3 As String الأن نقوم بتعريف المتغييرات على الأعمدة في ملف الأكسل من خلال التعريف xlWs.Cells(intLine, 1).Value حيث أن رقم 1 هو العمود رقم 1 في الاكسل و هكذا strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) تفضل التعديل Access-Import.accdb

بعد اذن استاذنا @kanory تفضل New Microsoft Access Database.rar

هذا ملفك بعد التطبيق New Microsoft Excel Worksheet.xlsb

Sub a_b() ' ' a_b Macro ' Macro recorded 12/11/2009 by USER ' ' Application.GoTo Reference:="sheet" Selection.Sort Key1:=Range("E7"), Order1:=xlAscending, Key2:=Range("F7") _ , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ :=xlSortNormal Range("A1").Select End Sub

شكرا جزيلا يا استاذ محمد انا بتعبك معايا كتير

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

السبب في ذلك هو طريقة إدخال البيانات حيث تم التعامل مع التاريخ على أنه نص وليس تاريخا والحل استعمال المعادلة التالية في الخلية G3 =VALUE(F3) مع سحب المعادلة لأسفل ثم نسخ بيانات هذا العمود الجديد ولصقها في عمود التاريخ كقيم مع تنسيق عمود التاريخ كتاريخ بعدها يمكن حذف العمود F بالتوفيق

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

وعليكم السلام ورحمة الله وبركاته اضعط زر Shift + زر 6 بالاعلى ^ تحياتي 10^9

تفضل اخي الكريم هذه طريقة افضل واسرع ضع الكود التالي في وحدة نمطية جديدة Public Function XNul(txt1 As Double, txt3 As Double) As Double If Nz(txt1, 0) > 0 And Nz(txt3, 0) > 0 Then XNul = (txt1 / txt3) * 100 Else XNul = 0 End If End Function ثم في الاستعلام ضع التالي مع تغيير اسماء الحقول Expr1: XNul(Nz([المدفوعات]);Nz([صافى الفواتير])) تحياتي

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

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

محاسب مبتدأ كلفت بعمل جرد يومي للفروع واريد ان اقوم بالجرد عن طريق شيت الاكسل المرفق ارجو الاطلاع جرد فوع.rar

تفضل جمع مدد الخدمة بالنموذج2.rar

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, r As Range, txt As String, i As Long Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) sh.Range("A3:C" & Rows.Count).ClearContents Set r = ws.Range("F2:M" & ws.Cells(Rows.Count, "F").End(xlUp).Row) a = r.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 8) = sh.Range("A1").Value Then txt = Join(Array(a(i, 2), a(i, 3)), Chr(2)) If Not .Exists(txt) Then .Item(txt) = .Count + 1 a(.Count, 1) = a(i, 2) a(.Count, 2) = a(i, 3) a(.Count, 3) = Evaluate("SUMIFS('" & ws.Name & "'!" & r.Columns(4).Address & ",'" & ws.Name & "'!" & r.Columns(1).Address & ","">=""&" & "'" & sh.Name & "'!" & Range("C1").Address & ", '" & ws.Name & "'!" & r.Columns(1).Address & ",""<="" &" & "'" & sh.Name & "'!" & Range("D1").Address & ",'" & ws.Name & "'!" & r.Columns(2).Address & "," & Chr(34) & a(.Count, 1) & Chr(34) & ",'" & ws.Name & "'!" & r.Columns(3).Address & "," & Chr(34) & a(.Count, 2) & Chr(34) & ")") End If End If Next i i = .Count End With sh.Range("A3").Resize(i, 3).Value = a End Sub

تفضل حسب طلبك Dim rs1, rs2, rs3, rs4 As Integer rs1 = (Me.YF * 360) + (Me.MF * 30) + Me.DF + (Me.YN * 360) + (Me.MN * 30) + Me.DN rs2 = (Me.yk * 360) + (Me.mk * 30) + Me.dk rs3 = rs1 - rs2 Me.TY = rs3 \ 360 Me.TD = rs3 Mod 30 rs4 = rs3 Mod 360 Me.TM = (rs4 - Me.TD) / 30 جمع الخدمة بالنموذج.rar

مبارك - نساله تعالى لكم التوفيق والتقدم ما شاء الله، أسأل الله أن يبارك لك وينفع بك أمة محمد صلى الله عليه وسلم

وعليكم السلام ورحمة الله وبركاته تفضل هذه تجرية iif(nz([المدفوعات])>0;(nz(المدفوعات)/nz(صافى الفواتير))*100;0) تحياتي

تفضل اخي الكريم Private Sub NO_AfterUpdate() DoCmd.SetWarnings False DoCmd.OpenQuery "Query1" DoCmd.SetWarnings True End Sub Private Sub NO_Exit(Cancel As Integer) Me.Requery End Sub Private Sub رقم_الموظف_GotFocus() DoCmd.GoToControl "NO" End Sub بيانات الموظفين.accdb تحياتي

الشكر لله الذي وفقنا جميعا للخير

ماشاء الله اسال الله ان يبارك لك

يمكنك استعمال هذا الكود في حدث عند التغيير في شيت سعد ولمن لا يعرف كيفية إضافة الكود في أحداث الصفحة كلك يمين على اسم الشيت ونختار view code بالعربي عرض التعليمات البرمجية ثم نلصق الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$F$5" Then Sheet24.Range("b10:i1000").ClearContents For r = 3 To Sheet14.Cells(Rows.Count, 2).End(3).Row If Sheet14.Range("n" & r) = Target Then lr = Sheet24.Cells(Rows.Count, 2).End(3).Row + 1 cols = Array(3, 2, 9, 10, 11, 5, 14, 15) For n = 2 To 9 Sheet24.Cells(lr, n) = Sheet14.Cells(r, cols(n - 2)) Next n: End If: Next r MsgBox "Done by mr-mas.com" End If End Sub بالتوفيق

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

الف مبروك و الي الامام دائما باذن الله 🌼

اوه رائع! تهانينا على الترقية! هذا يعني فقط أن عملك يلمس القلوب. على أي حال ، أتمنى أن تنجح في المستقبل. بارك الله.

تفضل التعديل ارجو ان يكون طلبك استعلام-1.rar

مجهود واضح واعمالك متقنة وان شاء الله من نجاح الى نجاح

ما شاء الله، أسأل الله أن يبارك لك وينفع بك أمة محمد صلى الله عليه وسلم.

الف مبروك على الترقية الى درجة خبير

مع كل الأسف الفيديو غير متوفر

مشاركة مع استاذ Eng.Qassim تفضل التعديل ارجو ان يكون طلبك INVOICES-2.rar

اسف جدا على التاخير لوجود عطل في حاسبتي ..تقوم بعمل استعلام لتحديث الحقل REF_INVOICE..يمكنك الاستفادة من المثال المرفق INVOICE.mdb

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

رائع أخي يحيى أحياك الله في طاعته

بارك الله فيك أخي عادل وفقك الله إلى ما فيه رضاه

أخي الكريم يمكنك استعمال هذه المعادلة قي التحقق من الصحة =COUNTIF($A$1:$A$19;$A1)<4 جرب وأخبرني بالنتيجة كان هذا ردي الذي حاولت إرساله سابقا ولكن نظرا لوجود عطل في النت عندي لم يتم إرساله

بارك الله فيك لردك الجميل.. يا أخي أنا فقط أعلم أن من يستطيع مساعدة غيره و لا يفعل فالله يغضب منه و أن أحب الأعمال إلى الله سرور تدخله على قلب مسلم.. و أنا بطبيعتي أحب مساعدة الآخرين إذا استطعت .... و أتمنى أن يكون كل الناس كذلك وأنا كذلك أشكرك أستاذي الفاضل على كلامك الجميل الذي يدل على الذوق الرفيع و جمال الشخصية ..أما عن ملاحظتك حول البرنامج فهذا صحيح تماماً أستاذ سالم .. و لكن هناك طريقة لتتمكن من تعديل مشروعك في أي وقت حيث أن برنامج الحماية LockXLS يسألك عند غلقه إن كنت تريد حفظ المشروع أم لا فإذا حفظت المشروع يمكنك العودة دائماً للملف الذي حفظته و التعديل فيما تريد أو تعود للملف الأصلي و تعدل فيه ثم تقوم بحمايته من جديد ..الهدف من البرنامج منع الغير من سرقة مجهودك فقد حدث هذا معي عندما قمت برفع جدول الحصص على المنتدى و قام أحد الإخوة بسرقته و تعديله و نسبه لنفسه و رفعه في منتدى آخر!!! فهل يرضيك أن يسرق أحدهم مجهودك هكذا ؟؟ لهذا السبب برنامج الحماية موجود.. أخي الكريم بارك الله فيك بالبحث في المنتدى بكلمة بحث "جدول" وجدت النتائج التالية =1]http://www.officena.net/ib/index.php?app=core&module=search&do=quick_search&search_sort_by=date&search_sort_order=desc&type=forum&type_id=14&search_term=%CC%CF%E6%E1&search_filter_app[forums]=1 وأعتقد أنه لم يتطرق لموضوع الجدول المدرسي إلا أنت وأنا مع مراعاة أنه: تم عرض موضوعي يوم 31/10/2009 بعنوان الجدول المدرسي http://www.officena.net/ib/index.php?showtopic=30034 وأول موضوع لك يتحدث عن الجدول هو جدول حصص نادر بتاريخ 7/11/2009 http://www.officena.net/ib/index.php?showtopic=30064 ثم توالت الإصدارات في برنامجك بتاريخ 9/11/2009 http://www.officena.net/ib/index.php?showtopic=30083 وبتاريخ أمس وعنوان جدول نادر 8 حصص معدل جديد http://www.officena.net/ib/index.php?showtopic=30083 فأتمنى توضيح من تقصد بمن لا يساعد الناس؟؟؟ ومن سرق مجهودك؟؟؟ لأن هذا قد يضر البعض ومنهم العبد لله تحياتي للجميع

حتى تعم الفائدة يمكنك إرفاق ملفك بعد وصولك للإجابة خالص تحياتي

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

رائع أخي خبور خير ما أجمل بساطة الأكواد جزاك الله خيرا

أخي الكريم سالم كما أخبر أخونا آدم ممكن يكون نقص في الملفات وأنا شخصيا لا أستعمل تعليمات الأوفيس المضمنة فيه وإنما أستخدم هذا الرابط