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

لتنفيذ هذه الفكرة ، يمكن اتباع الخطوات التالية :- 1. تحديد مسار حفظ الملفات لكل شعبة داخل مجلد مشترك على الشبكة ، قم بإنشاء مجلد رئيسي مثل \\Server\Documents\Books\ أنشئ داخله مجلدات لكل شعبة ، مثل :- \\Server\Documents\Books\Accounts 'قسم المحاسبة \\Server\Documents\Books\HR 'قسم شؤون الموظفين وأي اقسام أخرى حسب رغبتك طبعاً 2. إضافة جدول لحفظ بيانات الشعب في قاعدة البيانات أنشئ جدولاً جديداً باسم tblDepartments على سبيل المثال ، يحتوي على :- ID (رقم تلقائي) DeptName (اسم الشعبة) FolderPath (مسار مجلد الشعبة في الشبكة) 3. تصميم نموذج لاختيار الشعبة وإرسال الملف أضف نموذجاً جديداً باسم frmSendDocument أضف مربع قائمة منسدلة (ComboBox) مصدره جدول الشعب (tblDepartments) أضف زر إرسال يقوم بنسخ الملف إلى مجلد الشعبة المختارة . 4. الكود التالي لنقل الصورة إلى مجلد الشعبة المختارة عند الضغط على زر الإرسال ، استخدم الكود التالي :- Private Sub btnSend_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSourceFile As String Dim strDestinationFile As String Dim strDeptPath As String ' تحديد قاعدة البيانات Set db = CurrentDb Set rs = db.OpenRecordset("SELECT FolderPath FROM tblDepartments WHERE DeptName='" & Me.cboDepartment & "'", dbOpenSnapshot) ' التحقق من العثور على مسار الشعبة If Not rs.EOF Then strDeptPath = rs!FolderPath strSourceFile = Me.txtFilePath ' مسار الملف الأصلي strDestinationFile = strDeptPath & "\" & Dir(strSourceFile) ' نسخ الملف إلى مجلد الشعبة FileCopy strSourceFile, strDestinationFile MsgBox "تم إرسال الصورة إلى " & Me.cboDepartment, vbInformation Else MsgBox "لم يتم العثور على مسار الشعبة", vbCritical End If rs.Close Set rs = Nothing Set db = Nothing End Sub 5. برنامج الاستقبال في الأجهزة المستهدفة في البرنامج الخاص بكل شعبة ، يمكن عمل نموذج يقوم بفحص المجلد المحدد وعرض الملفات الجديدة . يمكن استخدام كود VBA لإنشاء زر تحديث يقوم بعرض الملفات الواردة تلقائياً . 6. ملاحظات حول الربط الشبكي تأكد أن جميع الأجهزة متصلة بالشبكة المحلية (Switch أو Router) . قم بمشاركة المجلد الرئيسي وإعطاء الصلاحيات المناسبة للمستخدمين . هذا تصور مبدئي للفكرة ، وتختلف آلية التنفيذ حسب طريقة تصميم مشروعك وبرنامجك .

جرب هل هدا ما تقصده Option Explicit Sub Split_names() Dim tbl&, tmp&, i&, Max&, c&, j&, lr&, r&, s& Dim n As String, ky As Boolean, ColArr As Range, OnRng As Range Dim Arr As Variant, rng As Variant, sp As Variant, Choisir As VbMsgBoxResult Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد") Dim dest As Worksheet: Set dest = Sheets("مؤشر الفائدة") Dim ColNam As String: ColNam = "DM" Choisir = MsgBox("تحديث البيانات ؟", vbYesNo + vbQuestion, "تأكيد") If Choisir <> vbYes Then Exit Sub Max = 444 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With On Error Resume Next tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max) WS.Range("DJ14:DJ" & tbl).ClearContents Set OnRng = WS.Range("T14:CC" & tbl) Arr = OnRng.Value For tmp = 1 To UBound(Arr, 1) n = "" ky = False For i = 1 To UBound(Arr, 2) If Arr(tmp, i) <> "" Then n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text) If Not ky Then WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat ky = True End If End If Next i WS.Cells(tmp + 13, 114).Value = n Next tmp On Error Resume Next Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not ColArr Is Nothing Then Arr = ColArr.Value ReDim rng(1 To UBound(Arr, 1), 1 To 1) For c = 1 To UBound(Arr, 1) rng(c, 1) = Arr(c, 1) Next c WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng End If dest.Range("AS2") = 2 dest.Range("I6:AL105").ClearContents lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value For j = 1 To UBound(Arr, 1) sp = Split(Arr(j, 1), "*") For r = LBound(sp) To UBound(sp) WS.Cells(j + 13, r + 118).NumberFormat = "@" WS.Cells(j + 13, r + 118).Value = sp(r) Next r Next j For s = 9 To 38 dest.Columns(s).EntireColumn.Hidden = (dest.Cells(5, s).Value = 0) Next s With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub نسب ومؤشر الفائدة v4.xlsb

إدا كنت ترغب في إستخدام الإقتراح المقدم من الأستاد @أبوعيد يمكنك تجربة هدا Public Property Get CrWS() As Worksheet Set CrWS = Sheets("ورقة1") End Property Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If c.Value <> "" Then Tbl.Item(c.Value) = c.Value Next c End If If Tbl.Count > 0 Then temp = Tbl.items Me.ComboBox1.List = temp End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String If Me.ComboBox1.Value <> "" Then ky = "=*" & Me.ComboBox1.Value & "*" lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False With CrWS.Range("B1:B" & lastRow) .AutoFilter Field:=1, Criteria1:=ky End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True Unload Me End If End Sub مسح صفوف معينة بناء على قيمتها v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim CrWS As Worksheet Dim lastRow As Long, tmps As Variant tmps = Array("=*كلية التربية*", "=*معهد عالي*") Set CrWS = Sheets("ورقة1") lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False With CrWS.Range("B1:B" & lastRow) .AutoFilter Field:=1, Criteria1:=tmps, Operator:=xlFilterValues End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True End Sub

اليك أخي @ahmedha هذا المرفق كنت سويته أحد الزملاء يمكن يساعدك اقرأة جيدا واذا احتاجت مساعدة حاضرين . GavanDB.rar

وعليكم السلام جرب هذا الملف تعديل مسح صفوف.xlsm

وعليكم السلام ورحمة الله وبركاته .. جرب أخي الكريم ما يلي :- 1- افتح CMD كمسؤول . 2- اكتب الأمر التالي سطراً تلو الآخر .. regsvr32 /u fm20.dll regsvr32 fm20.dll الهدف تحديث أو إعادة تسجيل مكتبات VBA فقط .

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

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