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

فعلا لم أنتبه لعناوين الأعمدة فهي AmX & Amy وما بعدها لذلك يجب الانتقال لأول الشيت بالضغط على CTRL+home مع ضبط الزووم على 100% كما قال أخي الفاضل حسونة لكن ردي السابق على اختفاء بيانات الخلايا في النطاق المستعمل فعلا يرجع بعضها للاسباب السابقة بالتوفيق

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

تفضل أخي الكريم تم استعمال نفس فكرة اليومي والخصم في نفس يوم تاريخ البداية مع اختلاف الشهور بالتوفيق خصم يومي أو شهري تلقائي .xlsx

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

برنامج صغير net cafe اتمنى ان يروق للأخوة ونرجو الإفادة timer.zip

عمل جميل رائع احترافي مختصر متقن ومرتب

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا بمكنك حدف السطور المخصصة للتحقق من أوراق العمل في حالة الرغبة لاختصار الكود Sub test1() Dim DataRng As Range, arr As Variant Dim Ct As Long, i As Long, tmp As Boolean Dim ws As Worksheet, dest As Worksheet Dim WSname As String, destName As String '****التحقق من وجود ورقة العمل المرغوب الترحيل منها WSname = InputBox(" : يرجى إدخال اسم الشهر المرغوب ترحيله") If Len(Trim(WSname)) = 0 Then MsgBox " تم إلغاء الترحيــل", vbExclamation Exit Sub End If On Error Resume Next Set ws = ThisWorkbook.Sheets(WSname) On Error GoTo 0 If ws Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If '****التحقق من وجود ورقة العمل المرغوب الترحيل اليها destName = InputBox(" : يرجى إدخال اسم الشهر المرحل إليه") If Len(Trim(destName)) = 0 Then MsgBox " تم إلغاء الترحيــل", vbExclamation Exit Sub End If On Error Resume Next Set dest = ThisWorkbook.Sheets(destName) On Error GoTo 0 If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If '***** نطاق البيانات Set DataRng = ws.Range("B5:B200") tmp = Application.WorksheetFunction.CountA(DataRng) > 0 If Not tmp Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في شهر", vbExclamation Exit Sub End If '****افراغ البيانات السابقة dest.Range("B5:B200").ClearContents ReDim arr(1 To DataRng.Rows.Count, 1) Ct = 0 For i = 1 To DataRng.Rows.Count If Len(DataRng.Cells(i, 1).Value) > 0 Then Ct = Ct + 1 arr(Ct, 1) = DataRng.Cells(i, 1).Value End If Next i ' لصق البيانات بداية من الصف 5 من ورقة الشهر المختارة If Ct > 0 Then For i = 1 To Ct dest.Range("B5").Offset(i - 1, 0).Value = arr(i, 1) Next i End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation End Sub ولنسخها بدون تكرار ستجد الكود داخل الملف المرفق ترحيل.xlsm

بطريقة أخرى Sub Advanced_REs_Data() Dim lr As Long, lr2 As Long, r As Long Dim f As Worksheet, WS As Worksheet Set f = Sheets("Data"): Set WS = Sheets("CAll") lr = f.Cells(Rows.Count, 2).End(xlUp).Row lr2 = WS.Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To lr f.Range("E" & r).Value = IIf(IsError(Application.Match(f.Cells(r, 2).Value, _ WS.Range("A2:A" & lr2), 0)), f.Range("E" & r).Value, _ Application.Index(WS.Range("C2:C" & lr2), _ Application.Match(f.Cells(r, 2).Value, WS.Range("A2:A" & lr2), 0))) Next r MsgBox "Process Completed", vbInformation, "Done" End Sub