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

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

هذا ملف جاهز لاستيراد الملفات بجانب قاعدة البيانات واستعراضها في متصفح (لعرض الصور + ملفات PDF) أو مستعرض الصور (بطريقتين) .. جعلت الأكواد ( إضافة - فتح - حفظ - حذف ) في موديول عام لذا يمكن الاستفادة منها في جميع النماذج بسطور قليلة ومبسطة .. Private Sub AddFilesBtn_Click() ' إضافة مرفق Dim Add Add = AddFiles(Me, Me.ID.Value) If Add = "" Then Exit Sub Me.FileName = Add End Sub Private Sub BrowserBtn_Click() ' استعراض المرفق Call BrowserAttachment(Me.FileName.Value) End Sub Private Sub DeletBtn_Click() ' حذف المرفق Call DeletFileFromAttacments(Me, "FileName", Me.FileName.Value) End Sub Private Sub DownloadBtn_Click() ' تحميل المرفق في جهازك Call SaveAttacment(Me.FileName.Value) End Sub وبه ميزة أن الروابط تتأقلم مع نقل البرنامج من مكان إلى آخر بشرط أن الملف attachments يجب أن يكون بجانب قاعدة البيانات دائما .. مستعرض الصور : العرض عن طريق المتصفح : للتحميل : حفظ المرفقات بجانب البرنامج دائما 2.rar

حمد لله على سلامة الرجوع 😅

عدم التوضيح من زمن = من 3 سنوات

حاول استخدام مكتبة WIA (Windows Image Acquisition) التي قد تكون متوافقة مع سكانر من نوع الـ HP

شكرا جزيلا اخي واستاذي ابو خليل المحترم.......... بارك الله بك اخي واستاذي Foksh . التعديل يعمل بامتياز

تستطيع فعلها كل ما عليك هنا هتعمل جدول فرعي لحفظ اسماء الملفات ويربطه بالجدول الرئيسي علاقة واحد لكثير وهنا هتحتاج تعمل بعض التعديل على الكود

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

تفضل أخي @mk_mk_79 Sub CopyHeaders() Dim lastRow As Long, tmp As Long Dim n As Long, Irow As Long, ColArr As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row Irow = 9 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Range("W" & Irow & ":Y" & WS.Rows.Count).ClearContents tmp = 7 Do While tmp <= lastRow If Not IsEmpty(WS.Cells(tmp, "F")) And Not _ IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then ColArr = Array(WS.Cells(tmp, "F").Value, _ WS.Cells(tmp, "L").Value, WS.Cells(tmp, "R").Value) n = 0 Do While tmp + n <= lastRow And _ (Not IsEmpty(WS.Cells(tmp + n, "F")) Or _ Not IsEmpty(WS.Cells(tmp + n, "L")) Or _ Not IsEmpty(WS.Cells(tmp + n, "R"))) n = n + 1 Loop With WS.Range(WS.Cells(Irow, "W"), WS.Cells(Irow + n - 1, "W")) .Value = ColArr(0) .Offset(0, 1).Value = ColArr(1) .Offset(0, 2).Value = ColArr(2) End With Irow = Irow + n + 3 tmp = tmp + n Else tmp = tmp + 1 End If Loop Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub طلبات v2 .xls

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

ما شاء الله عليك شغال بامتياز هذا هو المطلوب جزاك الله كل خير اخي وجعلها في ميزان حسناتك

اتفضل ملف المرفق بعد التعديل base_cham.rar

اتفضل هذا ما تريد ؟ base_s_w.rar

هل هذا ما تريد ؟

وعليكم السلام ورحمة الله تعالى وبركاته إليك المثال التالي أقل تاريخ.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub CopyHeaders() Dim lastRow As Long, tmp As Long, Irow As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row tmp = 7 Irow = 2 WS.Range("W8:Y" & WS.Rows.Count).ClearContents Do While tmp <= lastRow If Not IsEmpty(WS.Cells(tmp, "F")) And Not _ IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then With WS.Cells(tmp + Irow, "W") .Value = WS.Cells(tmp, "F").Value .Offset(0, 1).Value = WS.Cells(tmp, "L").Value .Offset(0, 2).Value = WS.Cells(tmp, "R").Value End With Do While tmp <= lastRow And _ (Not IsEmpty(WS.Cells(tmp, "F")) Or Not _ IsEmpty(WS.Cells(tmp, "L")) Or Not IsEmpty(WS.Cells(tmp, "R"))) tmp = tmp + 1 Loop Else tmp = tmp + 1 End If Loop Application.ScreenUpdating = True End Sub طلبات (1).xls

Function irow(ws As Worksheet, tmp As String) As Long Dim lastrow As Long, i As Long lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row For i = 7 To lastrow If ws.Cells(i, 5).Value = tmp Then irow = i Exit Function End If Next i irow = -1 End Function تعديل Private Sub CommandButton2_Click() Dim ws As Worksheet, linge As Long, i As Long Dim ColArr As Variant, arr() As Variant Set ws = ThisWorkbook.Sheets("البداية") Dim tmp As String: tmp = Me.TextBox3.Value If tmp = "" Then: MsgBox "الرجاء إدخال رقم الملف", vbExclamation, "خطأ": Exit Sub linge = irow(ws, tmp) If linge = -1 Then: MsgBox "رقم الملف غير موجود", vbExclamation, "خطأ": TextBox3.SetFocus: Exit Sub If MsgBox("هل أنت متأكد أنك تريد تعديل بيانات " & Me.TextBox4.Value & "؟", vbYesNo + vbQuestion, "تأكيد") = vbYes Then ColArr = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") arr = Array(Me.TextBox1.Value, Me.TextBox2.Value, Me.TextBox3.Value, _ Me.TextBox4.Value, Me.TextBox5.Value, Me.TextBox6.Value, _ Me.TextBox7.Value, Me.TextBox8.Value, Me.TextBox9.Value, _ Me.TextBox10.Value, Me.TextBox11.Value, Me.TextBox12.Value) Application.ScreenUpdating = False For i = LBound(arr) To UBound(arr) If i <= UBound(ColArr) Then ws.Cells(linge, ColArr(i)).Value = arr(i) End If Next i UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم تعديل البيانات بنجاح", vbInformation End If End Sub ترحيل Private Sub CommandButton1_Click() Dim ws As Worksheet, lastrow As Long Dim arr() As Variant, ColArr As Variant, tmp As String Set ws = ThisWorkbook.Sheets("البداية") lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row tmp = Me.TextBox3.Value If tmp = "" Then MsgBox "الرجاء إدخال رقم الملف", vbExclamation, "خطأ": Exit Sub If TextBox4.Value = "" Then MsgBox "يرجى ادخال اسم صاحب المعاش", vbExclamation: TextBox4.SetFocus: Exit Sub If TextBox6.Value = "" Then MsgBox "يرجى ادخال اسم الفاحص", vbExclamation: TextBox6.SetFocus: Exit Sub If WorksheetFunction.CountIf(ws.Range("E7:E" & lastrow), tmp) > 0 Then MsgBox "رقم الملف موجود بالفعل", vbExclamation, "تكرار رقم الملف": Exit Sub End If ColArr = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") arr = Array(Me.TextBox1.Value, Me.TextBox2.Value, tmp, TextBox4.Value, _ Me.TextBox5.Value, TextBox6.Value, Me.TextBox7.Value, _ Me.TextBox8.Value, Me.TextBox9.Value, Me.TextBox10.Value, _ Me.TextBox11.Value, Me.TextBox12.Value) Application.ScreenUpdating = False For i = LBound(arr) To UBound(arr) ws.Cells(lastrow + 1, ColArr(i)).Value = arr(i) Next i With ws.Range("C7:C" & ws.Cells(ws.Rows.Count, "D").End(xlUp).row) .Value = Evaluate("ROW(" & .Address & ")-6") End With For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" Next ctrl UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم إدخال البيانات بنجاح", vbInformation, "نجاح" End Sub تعديل فورم.rar

يعني تريد توثيق للتعديلات والحذف والاضافة ..... ابحث في المنتدى تجد العديد من المواضيع مثل هذا للاستاذ @jjafferr

أخى عبد الله تمت التجربة وأصبح لدينا معادلة وكود وكلاهما أكثر من رائع بارك الله فيك أخى الفاضل وجزاكم الله خيرا

جرب الكود التالى النتيجة فى G2 بمكن تعديلها فى الكود Sub CalculateResult() Dim cellCount As Long Dim result As Variant Dim dataRange As Range Dim cell As Range Set dataRange = Sheets("طباعة").Range("B7:I11") cellCount = 0 For Each cell In dataRange If cell.Value <> 0 And cell.Value <> "" Then cellCount = cellCount + 1 End If Next cell Select Case Sheets("طباعة").Range("F2").Value Case "الأول", "الثانى" If cellCount >= 25 Then result = 25 Else result = cellCount End If Case "الثالث" result = cellCount Case Else result = "" End Select Sheets("طباعة").Range("G2").Value = result MsgBox "تم حساب النتيجة: " & result الملف عدد الخلايا بشروط.xlsx

وعليكم السلام ورحمة الله وبركاته ويسعدنى ويشرفنى حضورك المبارك فى هذه المشاركة الفعالة اخى الفاضل / أبو مروان الكود بعمل بشكل رائع ويعطى نتائج صحيحة 100% فى حالة عدم إحتواء الخلايا على معادلات أما الملف الأصلى يحتوى على معادلات فهل من سبيل لتعديل ماتفضلت به بإستخدام الدالة SUMPRODUCT من باب تنوع الحلول لمواجهة هذة المشكلة مستقبلا لدى الكثير من الزملاء هنا برجاء الإطلاع على المرفق الذى يحتوى على معادلة الأستاذ / عبدالله بشير التى جاءت بالنتائج المرجوة بنسبة 100% والكود الخاص بكم فى محاوله أخرى منك أخى الكريم وشاكر فضل حضراتكم وجزاكم الله خيرا عدد الخلايا بشروط - الأستاذ عبدالله - ابو مروان.xlsm

وعليكم السلام مقاييس الصفحة الموجودة في التقرير يتم اخذها من الطابعة الافتراضية ، الى ان يقوم المستخدم باختيار طابعة اخرى ، لذا ، اذا الطابعة التي يقوم باختيارها المستخدم لا تحتوي على A3 ، فلن تجد هذا الاختيار من القائمة. يمكنك استخدام طابعة pdf افتراضية ، واجعل حجم الصفحة فيها الذي تريده ، سواء A3 او اكبر ، وستجد هذا الحجم موجود عند اختيارك لطابعة الـ pdf . انا استعمل هذه الطابعة المجانية :

السلام عليكم تم انشاء ملف جديد باسم نتائج المقارنة تم وضع كود به اضغط على الزر فقط بشرط الملفين تشرين وايلول يكونان مقفلين وان بكونا على سطح المكتب بمعنى الملفات الثلاتة على سطح المكتب وبنفس الاسماء الحالية يمكنك تعديل الاسماء من الكود ان اردت Sub CompareSalaries() Dim desktopPath As String Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet Dim resultWb As Workbook, resultWs As Worksheet Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long Dim empName As Variant Dim salary1 As Double, salary2 As Double Dim dictSalaries1 As Object, dictSalaries2 As Object desktopPath = Environ("UserProfile") & "\Desktop\" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(desktopPath & "__ايلول_.xlsx") Set wb2 = Workbooks.Open(desktopPath & "__تشرين الاول_.xlsx") Set resultWb = Workbooks("نتائج المقارنة.xlsB") Set ws1 = wb1.Sheets("ورقة1") Set ws2 = wb2.Sheets("ورقة1") Set resultWs = resultWb.Sheets("ورقة1") resultWs.Range("A2:D" & resultWs.Rows.Count).ClearContents resultWs.Range("A1:D1").Value = Array("الاسم", "الحالة", "راتب أيلول", "راتب تشرين الأول") Set dictSalaries1 = CreateObject("Scripting.Dictionary") Set dictSalaries2 = CreateObject("Scripting.Dictionary") lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow1 empName = ws1.Cells(i, 1).Value salary1 = ws1.Cells(i, 2).Value dictSalaries1(empName) = salary1 Next i lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow2 empName = ws2.Cells(i, 1).Value salary2 = ws2.Cells(i, 2).Value dictSalaries2(empName) = salary2 Next i j = 2 For Each empName In dictSalaries1.Keys If dictSalaries2.exists(empName) Then salary1 = dictSalaries1(empName) salary2 = dictSalaries2(empName) If salary1 <> salary2 Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "تغير في الراتب" resultWs.Cells(j, 3).Value = salary1 resultWs.Cells(j, 4).Value = salary2 j = j + 1 End If Else resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "محذوف" resultWs.Cells(j, 3).Value = dictSalaries1(empName) resultWs.Cells(j, 4).Value = "" j = j + 1 End If Next empName For Each empName In dictSalaries2.Keys If Not dictSalaries1.exists(empName) Then resultWs.Cells(j, 1).Value = empName resultWs.Cells(j, 2).Value = "جديد" resultWs.Cells(j, 3).Value = "" resultWs.Cells(j, 4).Value = dictSalaries2(empName) j = j + 1 End If Next empName wb1.Close False wb2.Close False resultWs.Columns("A:D").AutoFit With resultWs.Range("A1:D" & j - 1).Borders .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With MsgBox "تمت المقارنة وتم عرض النتائج في ورقة 'ورقة1' في مصنف 'نتائج المقارنة.xlsx'.", vbInformation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not wb1 Is Nothing Then wb1.Close False If Not wb2 Is Nothing Then wb2.Close False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub الملف نتائج المقارنة.xlsb

وعليكم السلام ورحمة الله وبركاته احاول افهم قصدك: 1. عندك استعلام بمعايير معينة ، 2. احد حقول الاستعلام تم تغيير قيمته ، وهو نقل موظف الى مكان آخر ، تريد تعرف هذا الموظف؟ اذا كان هذا سؤالك ، فالجواب: لا يمكن ، فالاستعلام يعطيك صورة من بيانات الجدول. نعم يمكن ، اذا عملت جدول خاص بتخزين قيم هذا الحقل بشكل سجل/سجلات ، ويمكن مقارنة هذه السجلات بقيم الجدول الحالي لهذا الحقل. 3. لم افهم ما دور الكومبوبوكس والتقرير.

وعليكم السلام ورحمة الله تعالى وبركاته في الخلية A4 ضع احدى المعادلات التالية مع سحبها يسارا لغاية عمود L وسحبها أسفل لغاية الصف الدي يناسبك =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, SMALL(IF('بيانات الطلاب'!$B$3:$B$100=$B$1, ROW('بيانات الطلاب'!$B$3:$B$100)-ROW('بيانات الطلاب'!B$3)+1), ROW(1:1))), "") أو =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, AGGREGATE(15, 6, ROW('بيانات الطلاب'!$B$3:$B$100) -ROW('بيانات الطلاب'!B$3)+1/( 'بيانات الطلاب'!$B$3:$B$100=$B$1), ROW(1:1))), "") أو =FILTER('بيانات الطلاب'!A$3:A$100, 'بيانات الطلاب'!$B$3:$B$100 = $B$1) متابعة الطلاب.xlsx باستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Long, j As Long, clé As String, IRow As Long, col As Long Dim WS As Worksheet: Set WS = Worksheets("بيانات الطلاب") Dim F As Worksheet: Set F = Worksheets("متابعة الطلاب") If Not Intersect(Target, Me.Range("B1")) Is Nothing Then d = 4 clé = F.Range("B1").Value IRow = WS.Range("B3:B" & WS.Rows.Count).Find("*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Application.ScreenUpdating = False F.Range("A4:L" & F.Rows.Count).ClearContents For j = 3 To IRow If WS.Cells(j, 2).Value = clé Then For col = 1 To 12 F.Cells(d, col).Value = WS.Cells(j, col).Value Next col d = d + 1 End If Next j Application.ScreenUpdating = True End If End Sub متابعة الطلاب.xlsb

السلام عليكم ان شاء الله هذا طلبك متابعة الطلاب1.xlsm

وعليكم السلام ورحمة الله وبركاته.. مشاركة و إضافة لما تفضل به معلمي الجليل الأستاذ أبو خليل ، جرب حصر المعيار بعلامتي تنصيص ، كالآتي :- If Not IsNull(Me.Mo) Then varFilter = (varFilter + " AND ") & "[Mo] = " & Me.Mo End If جرب وأخبرنا بالنتيجة 😇

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اخي Option Explicit Sub Search_Transfer() Dim WS As Worksheet, cel As Range, lr As Long, Temp(), I As Long, J As Long, X Set WS = ThisWorkbook.Worksheets("Sheet2") lr = WS.Cells(Rows.Count, "R").End(xlUp).Row For Each cel In WS.Range("R5:R" & lr) If cel <> "" Then X = Application.Match(cel, WS.Columns(13), 0) If Not IsError(X) Then I = I + 1 ReDim Preserve Temp(1 To 15, 1 To I) Temp(1, I) = I For J = 2 To 15 Temp(J, I) = WS.Cells(X, J).Value Next J End If End If Next cel Temp = Application.Transpose(Temp) If I > 0 Then WS.Range("V5").Resize(I, UBound(Temp, 2)).Value2 = Temp End Sub