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

فيديو الشرح احببت مشاركتكم لهذا الفيديو المشار اعلاه والتي تقوم فكرته على وللذين لديهم معرفة ولو بسيطة عن البايثون فلو اردت مشاركة بياناتك الحالية مثل كشف حساب او ادخالاتك مع احد الاشخاص على الانترنت استخدام streamlit او flask او flet لانشاء نماذج المستخدم استخدلم sqlalchemy لاستخام عبارات ال sql استخدام ngrok لنشر الداتا على الانترنت مع مراعاة استخدام بايثون 64 او 32 بت حسب الاوفيس ان كان32 او 64 وايضا engine office العملية سهلة التطبيق وكذلك الاكواد مرفقة بالفيديو

الشكر لله اخى ربنا يجعل هذا العمل في ميزان حسناتك اخي

شكرا اخي العزيز لارفاق الملف بدل وضع رابط له 🙂

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Range, arr As Range, dict As Object, n As Long, f As String Dim lastRow As Long, SumCol As Long, a As Long Dim WS As Worksheet: Set WS = Me lastRow = WS.Columns("C:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Not Intersect(Target, WS.Range("C6:D" & lastRow)) Is Nothing Then With Application .DisplayAlerts = False .ScreenUpdating = False If lastRow > 6 Then With WS.Range("E6:E" & lastRow) .UnMerge .ClearContents End With End If Set dict = CreateObject("Scripting.Dictionary") SumCol = WS.Cells(WS.Rows.Count, 3).End(xlUp).Row Set OnRng = WS.Range("C6:C" & SumCol) Set arr = WS.Range("D6:D" & SumCol) For n = 1 To OnRng.Rows.Count f = Trim(OnRng(n).Value) If Len(f) > 0 And IsNumeric(arr(n).Value) Then If dict.Exists(f) Then dict(f) = dict(f) + arr(n).Value Else dict.Add f, arr(n).Value End If End If If Len(Trim(arr(n).Value)) = 0 Then WS.Cells(n + 5, 5).Value = "" End If Next n n = 6 Do While n <= SumCol f = Trim(WS.Cells(n, 3).Value) If Len(f) > 0 Then If dict.Exists(f) Then WS.Cells(n, 5).Value = dict(f) a = n Do While n <= SumCol And Trim(WS.Cells(n, 3).Value) = f n = n + 1 Loop If n - a > 1 Then WS.Range(WS.Cells(a, 5), WS.Cells(n - 1, 5)).Merge End If Else n = n + 1 End If Else n = n + 1 End If Loop Set dict = Nothing .ScreenUpdating = True .DisplayAlerts = True End With End If End Sub جمع ودمج بشرط التاريخ.xlsm

بالنسبة تكست 18 و19 اذهب الى لوحة التحكم - الساعة والمنطقة - المنطقة - ثم كما بالصورة الملف اظهار نتائج البحث في اللستبوكس1.xlsm

وعليكم السلام دالة recherchv لا اجيدها واعتقد انها فرنسية ولكن قمت بحل اخر وان لم يكن مناسبا لك قم بفتح موضوع جديد واطلب فيه دالة recherchv وستجد من الخبراء من يقوم بذلك تحياتي اسم المقاطعة.xlsb

السلام عليكم تم تعديل النقطتين الاولى والثانية والثانية كان سببها اكثر من رقم حساب مكرر النقطتان 3 4 ان شاء بعد العودة من العمل جرب المرفق ولاحرج في اي ملاحظة تقبل تحياتي اظهار نتائج البحث في اللستبوكس1.xlsm

جزاك الله خير تسلم

حسب علمي .. حقل المرفقات يختلف عن الحقل النصي لأن الوصول الى خصائص الصورة داخل حقل المرفقات مختلف بمعنى الصورة التي يحتويها ليس لها خصيصة : picture فأمامك حل من اثنين : اما يكون الجدول مصدر للتقرير واما ان يتم اخراج المرفق كصورة خارج قاعدة البيانات وهنا يمكننا اظهار الصورة في التقرير وبما انك ذكرت ان مصدر التقرير ليس الجدول فإليك الحل الآخر . Sub SaveAttach() On Error Resume Next Dim rs As dao.Recordset Dim strobj As dao.Recordset Dim strPic As String strPic = CurrentProject.Path & "\pic.JPG" Set rs = CurrentDb.OpenRecordset("Table1") Set strobj = rs.Fields("logo").Value strobj.Fields("FileData").SaveToFile strPic Me.Image0.Picture = strPic End Sub Private Sub Report_Load() Call SaveAttach End Sub 220.rar

استاذى الجليل عبدالله بشير عبدالله شكرا جزيلا على التفاعل والاهتمام وجزاك الله خير لكن لى ملاحظات اخجل من طلبها 1- اريد عند مسح محتويات TEXTBOX1 يتم تفريغ التكستبوكس والكومبوبوكس 2-عن اختيار نتائج الللست بوكس تظهر فى التكستبوكس و الكومبوبوكس بياناات لا تخص رقم الحساب المحدد فى اللست بوكس 3- اريد عن كتابة او عند عرض محتويات TextBox17 و TextBox18 تظهر فى تنسيق YYYY/MM/DD 4- اريد عن كتابة او عند عرض محتويات TextBox4تظهر فى تنسيق YYYY/MM وجزاك الله واسف على الاطالة

هو كود صغير يقوم بالمهمة وقبل الحذف يسالك هل تريد الحذف ام لا مع عدد من تم حذفهم الكود Sub DeleteRows() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim deleteCount As Long Dim response As VbMsgBoxResult Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row deleteCount = 0 response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then For i = lastRow To 3 Step -1 If ws.Cells(i, 2).Value <> "" And ws.Cells(i, 3).Value <> "" Then ws.Rows(i).Delete deleteCount = deleteCount + 1 End If Next i MsgBox deleteCount & " صفوف تم حذفها.", vbInformation, "عملية الحذف" Else MsgBox "تم إلغاء عملية الحذف.", vbInformation, "إلغاء" End If End Sub الملف حذف اسماء من استلمو الاول والثاني.xlsm

السلام عليكم المعادلة =HYPERLINK("#'" & A2 & "'!A1"; A2) الملف ارتباط تشعبى شيت بخلية.xlsx

السلام عليكم اكتب الرقم في العمود F الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim districtNumber As String Dim count As Integer Dim districtList As String Dim cell As Range Dim districtArray() As String Dim i As Integer Dim selectedDistrict As String Set ws = ThisWorkbook.Sheets("Feuil2") If Not Intersect(Target, ws.Range("F5:F" & ws.Cells(ws.Rows.count, "F").End(xlUp).Row)) Is Nothing Then districtNumber = CStr(Target.Value) If districtNumber <> "" Then count = Application.WorksheetFunction.CountIf(ws.Range("A2:A500"), districtNumber) If count > 1 Then districtList = "" For Each cell In ws.Range("A2:A" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row) If cell.Value = districtNumber Then If districtList = "" Then districtList = ws.Cells(cell.Row, "B").Value Else districtList = districtList & "," & ws.Cells(cell.Row, "B").Value End If End If Next cell districtArray = Split(districtList, ",") With UserForm1.ListBox1 .Clear For i = LBound(districtArray) To UBound(districtArray) .AddItem districtArray(i) Next i End With UserForm1.Show If UserForm1.ListBox1.ListIndex <> -1 Then selectedDistrict = UserForm1.ListBox1.Value Else selectedDistrict = "" End If Target.Offset(0, 1).Value = selectedDistrict Else For Each cell In ws.Range("A2:A" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row) If cell.Value = districtNumber Then Target.Offset(0, 1).Value = ws.Cells(cell.Row, "B").Value Exit For End If Next cell End If End If End If End Sub الملف اسم المقاطعة.xlsb

هذا يعتمد على طريقة بنائك لعناصر القائمة ليست بوكس أثناء إضافة العناصر إليها يمكنك التحكم في تنسيق القيم الموجودة في الخلايا مثلا بهذه الصورة Dim i As Integer For i = 1 To 10 ListBox1.AddItem Format(Cells(i, 1).Value, "0.00") Next i هذا الكود يقوم بإضافة الخلايا من A1:A10 إلى القائمة وتنسيق الرقم بها إلى رقمين عشريين بالتوفيق