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

هل جربت الكود اخي الكريم ...... أم تتحدث قبل التجريب .... على العموم تفضل ملف بعد التعديل ..... تأريخ تلقائي.rar

وهذه طريقة اخرى ، لعمل النسخ الاحتياط مباشرة على Google Drive جعفر

وعليكم السلام 🙂 البرنامج فيه خطأ !! المفروض لما تختار من ايقونة مسار التحديث ، وتختار المسار ، المفروض ان يتم تثبيته ، واستعماله ، ولكن السطر التالي من كود زر الحفظ ، لا يراعي ذلك ، وفي نفس السطر يمكنك تغيير المسار (الثانوي/الاضافي) اذا وُجد ، تغيير السطر التالي DstFile = CurrentProject.Path & "\Copy\نظام ادارة شؤون التلاميذ الاصدار 1.00-" & Format(Now, "dd-mm-yyyy") & "-" & Format(Now, "hh-nn-ss") & ".accdb" CurrentProject.Path معناه المجلد الذي به قاعدة البيانات بينما نريد ان نحفظه في المسار الذ اخترناه الى DstFile = Copy_Path & "\Copy\نظام ادارة شؤون التلاميذ الاصدار 1.00-" & Format(Now, "dd-mm-yyyy-hh-nn-ss") & ".accdb" بينما اذا لم نرد ان نحفظه في اي مجلد ثانوي ، وانما حفظه في المسار الذي تم اختياره من الايقونة DstFile = Copy_Path & "\" & "نظام ادارة شؤون التلاميذ الاصدار 1.00-" & Format(Now, "dd-mm-yyyy-hh-nn-ss") & ".accdb" جعفر

وعليكم السلام-تفضل Option Explicit Private IsArrow As Boolean Private Sub ComboBox1_Change() Dim i As Long If Not IsArrow Then With Me.ComboBox1 .List = Worksheets("Sheet1").Range("A4", Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)).Value .ListRows = Application.WorksheetFunction.Min(6, .ListCount) .DropDown If Len(.Text) Then For i = .ListCount - 1 To 0 Step -1 If InStr(1, .List(i), .Text, vbTextCompare) = 0 Then .RemoveItem i Next .DropDown End If End With End If End Sub Private Sub ComboBox1_DropButtonClick() With Me.ComboBox1 .List = Worksheets("Sheet1").Range("A4", Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)).Value .ListRows = Application.WorksheetFunction.Min(6, .ListCount) .DropDown End With End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Debug.Print Time; "KeyDown"; KeyCode; ComboBox1.ListIndex; ComboBox1.ListCount, ComboBox1.Value IsArrow = (KeyCode = vbKeyUp) Or (KeyCode = vbKeyDown) If KeyCode = vbKeyReturn Then Me.ComboBox1.List = Worksheets("Sheet1").Range("A4", Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)).Value ElseIf KeyCode = vbKeyTab Then With Me.ComboBox1 If .ListIndex = -1 Then .Value = .List(0) Else .Value = .List(.ListIndex) End If End With KeyCode = vbKeyReturn End If End Sub القائمة بالكومبوبوكس1.xlsm

اخي في الله @abouelhassan اعمل افضل اجابة حتى يعلم الاخوة الافاضل انه تمت الاجابة

اتفضل دبل كليك على حاله الصرف وسيتم اتاحه التعديل ثم عند الخروج سيتم تفعيل الوضع غير ممكن التعديل بالتوفيق TestLOck -2.accdb

ارفع نموذج للعمل عليه حتى يمكن للاساتذه بارك الله فيهم ان يساعدوك

جميعا بإذن الله

جزاك الله عنا خيرا

اخي عمار 🙂 رجاء عدم كتابة اكثر مو موضوع بنفس السؤال. مكرر يُغلق

في شرحك ثلاث قيم للادخال وهي ( Com.Amount و Pers و Earning ) وفي النموذج قيمتان وهي ( Pers و Earning ) ...... اين الثالثة Com.Amount ........ انظر الصورة

الشكر لله ثم لاخواننا واساتذتنا جزاهم الله عنا كل خير والشكر موصل لاخى ومهندسنا العزيز @Eng.Qassim 🌹 تقبلوا تحياتى وبالتوفيق

طبعا me.kano هو مربع نص يتم اضافته للنموذج الرئيسي ويتم فيه ادخال بداية التاريخ

تفضل ..... Sub kan() On Error GoTo w Dim i As Integer Dim sCount As Integer sCount = Me.Recordset.RecordCount DoCmd.GoToRecord , , acFirst For i = 0 To Me.Recordset.RecordCount Me.datem = DateAdd("d", i, Me.kano) DoCmd.GoToRecord , , acNext Next DoCmd.Requery Exit Sub w: MsgBox "تم" End Sub Private Sub تأريخ_تلقائي_Click() Me.kano = Me.datem kan End Sub

In standard module, put the following UDF Function VLookUps(myCode As Range, myList As Range, delim As String, Optional Uniq As Boolean = False) As String Dim e VLookUps = Join(Filter(myList.Parent.Evaluate("TRANSPOSE(IF(" & myList.Columns(7).Address & "=" & myCode.Address(, , , True) & ", " & myList.Columns(2).Address & "))"), False, 0), delim) If Uniq Then With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each e In Split(VLookUps, delim) .Item(Trim(Split(e)(1))) = Empty Next e VLookUps = Join(.Keys, delim) End With End If End Function In cell F2, you can use the UDF as following =VLookUps(Tabla2[@[إسم ولي الأمر]],Tabla1[#All]," - ",TRUE)

بعد إذن جميع الأصدقاء المشاركين في هذا الموضوع الرائع هذا جهدي المتواضع لتحميل الملفات من جوجل درايف بنفس الاسم والامتداد فقط تحتاج رابط الملف كاملا وأن يكون الملف عاما (مشاركا مع الجميع) الكود يعالج مشكلة أسماء الملفات العربية صالح للنواتين 32بت وكذلك 64بت يعمل في كل التطبيقات التي تستعمل vba يوضع هذا الكود في موديول جديد Sub DownloadFromGD(GDriveURL As String) Dim myURL As String Dim FileID As String Dim xmlhttp As Object Dim name0 As Variant Dim oStream As Object FileID = Split(Split(GDriveURL, "/d/")(1), "/")(0) myURL = "http://drive.google.com/u/0/uc?id=" & FileID & "&export=download" Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP") xmlhttp.Open "GET", myURL, False xmlhttp.Send name0 = DECODEURL(xmlhttp.getResponseHeader("Content-Disposition")) If name0 = "" Then MsgBox "الملف غير موجود في الموقع" Exit Sub End If name0 = Split(name0, "*=UTF-8''")(1) 'split after *=UTF-8'' to get utf8 names If xmlhttp.Status = 200 Then Set oStream = CreateObject("ADODB.Stream") oStream.Open oStream.Type = 1 oStream.Write xmlhttp.responseBody oStream.SaveToFile CurrentProject.Path & "\" & name0, 2 ' 1 = no overwrite, 2 = overwrite oStream.Close End If Set xmlhttp = Nothing Set Stream = Nothing MsgBox "تم تحميل الملف في نفس مسار البرنامج باسم: " & name0 End Sub Function DECODEURL(varText As Variant) Static objHtmlfile As Object If objHtmlfile Is Nothing Then Set objHtmlfile = CreateObject("htmlfile") objHtmlfile.parentWindow.execScript "function decode(s) {return decodeURIComponent(s)}", "jscript" End If DECODEURL = objHtmlfile.parentWindow.decode(varText) End Function طريقة استخدام الكود مثل السطر المكتوب في الإجراء test أو يمكن وضعه عند الضغط على زر مثلا ويتكون هذا السطر من كتابة اسم الاجراء DpwnloadFromGD ثم رابط الملف المراد تحميله بين علامتي تنصيص ويمكن استخدام قيمة مربع النص بدلا من تثبيت رابط الموقع Sub test() DownloadFromGD "https://drive.google.com/file/d/18jrvTxgR1QTzwm8YaJHIvsdOmqj02L2x/view" End Sub ولا تنسوني من صالح دعائكم بالتوفيق للجميع

عليكم السلام ورحمة الله وبركاته كل خلية يوجد بها أكثر من بيان بينهما سطر جديد داخل نفس الخلية وبعض الخلايا تحتوي على سطرين و بعضها يحتوي على 3 سطور وبعضها يحتوي على 4 سطور وبعضها يحتوي على 5 سطور ويوجد تقريبا 6 سطور أيضا و بعضها يحتوي على سطر واحد فقط هل المطلوب جلب بيانات آخر سطر داخل الخلية يعني السطر الثاني في حالة وجود 2 والثالث في حالة وجود 3 وهكذا ؟؟؟ مع العلم ليست كل الخلايا في نفس الصف منضبطة في عدد السطور فمثلا الصف 17 أول 4 أعمدة يوجد في الخلية 4 سطور وفي العمودين 5 و 6 في نفس الصف نجد الخلية بها 5 سطور وهذا الاضطراب لا يسمح بضبط الأمر فأول خطوة للحصول على المطلوب هو ضبط عدد السطور في كل صف بالتوفيق

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

السلام عليكم ورحمة الله يجب تغيير تنسيق عمود الفصل الى Text

السلام عليكم ورحمة الله اذن لا مناص من استخدام الكود التالى Sub TrData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Long, j As Integer, p As Long Dim Arr As Variant, Tmp As Variant, Fsl As String Application.ScreenUpdating = False Set ws = Sheets("قوائم الفصول") Set Sh = Sheets("مجمع الشيتات") LR = Sh.Range("E" & Rows.Count).End(3).Row ws.Range("C" & ws.Range("E" & Rows.Count).End(3).Row + 1) = "" Fsl = ws.Range("F4").Value If IsEmpty(Fsl) Then Exit Sub Arr = Sh.Range("C10:P" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 13) = Fsl Then p = p + 1 For j = 1 To 8 Tmp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5, 7, 9, 10, 13)) Tmp(p, 1) = p Next End If Next If p > 0 Then ws.Range("C10").Resize(p, UBound(Tmp, 2)).Value = Tmp Application.ScreenUpdating = True End Sub

حسب فهمي للمطلوب يمكنك إضافة هذا الكود في نهاية إجراء الطباعة Sub PRINT_OUT lr = Cells(Rows.Count, 1).End(xlUp).Row For r = 8 To lr rw = Application.WorksheetFunction.Match(Range("A" & r).Value, Sheets("التحميل").Range("A:A"), 0) Sheets("التحميل").Range("Q" & rw).Value = "تم الصرف" Next r وهو للحصول على رقم الصف الذي يحتوي على رقم المستند الموجود في الخلية A8 وما بعدها عند البحث عنه في العمود A في شيت التحميل ثم تغيير قيمة الخلية Q في نفس الصف إلى تم الصرف بالتوفيق

تفضل اخى الكريم ترحيل الغياب.xlsm

وعليكم السلام ورحمة الله وبركاته تفضل اخى الكريم ترحيل الغياب.xlsm

تفضل seddiki_adz .. ولكن هذه مسألة بسيطة جداً وكان عليك وضع الكود بالملف بنفسك .. وطالما انك تريد حل مشكلتك بالأكواد فكان عليك من باب أولى رفع الملف بإمتداد يقيل اضافة الأكواد من البداية مثل Xlsm والشكر موصول لأستاذنا الكبير lionheart ولكن بكل بساطة لإضافة الكود بالملف عليك بالضغط على Alt+F11 ثم بعد ذلك الضغط على قائمة Insert واختيار Module ستفتح لك نافذة جديدة عليك بلصق الكود بها وشكراً BINOME2223.xlsm

السلام عليكم ورحمة الله وبركاته فكرة بسيطة لترجمة الاسماء باللغة العربية الى اللغة الانجليزية ممكن تجربته names.xlsm