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

حسناً يجب أخذ في عين الإعتبار وجود نفس القيمة مكررة في أكثر من خلية مع أني لا أعتقد ذلك بحسب المعادلة التي وضعها السيد مشعل لكن بكل الأحوال ممكن تجربة هذا الكود Sub test() Dim i& Dim x As String Dim r As Range Application.ScreenUpdating = False Range("A1:AI35").Interior.Color = xlNone For i = 14 To 15 With Range("A1:AI35") Set r = .Cells.Find(Range("AL" & i), , , 1) x = r.Address Do r.Interior.Color = vbRed Set r = .Cells.FindNext(r) Loop Until r.Address = x End With Next Application.ScreenUpdating = True End Sub 'وأيضاً لتلوين كل رقم بلون مختلف Sub test2() Dim i& Dim x As String Dim r As Range Dim f As Boolean Application.ScreenUpdating = False Range("A1:AI35").Interior.Color = xlNone For i = 14 To 15 With Range("A1:AI35") Set r = .Cells.Find(Range("AL" & i), , , 1) x = r.Address Do r.Interior.Color = IIf(f, vbRed, vbYellow) Set r = .Cells.FindNext(r) Loop Until r.Address = x End With f = True Next Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته 'طباعة حسب البيانات.xlsm

بسم الله الرحمن الرحيم السلام عليكم ورحمه الله وبركاته اساتذتي واخوتى هذا الملف به فهرس لجميع المنتدي ليسهل البحث للاعضاء يوجد فورم يمكنك البحث بها كما يمكنكم استخدام الفلتر العادي وبمجرد الضغط على اي نتيجه من نتائج البحث يتم فتح صفحتها في المنتدي ولا انسي فضل استاذي الكبير ياسر خليل على المساعده في عمل الملف فهرس منتدي الاكسيل.xlsb

بسم الله والحمد لله ولا اله الا الله والله اكبر الحمد لله رب العالمين الحمد الله الذى تتم بنعمته الصالحات شكر وتقدير لكل معلمينا فى هذا الصرح الشامخ على وجه العموم وشكر خاص لكل من المعلمين [ ابو خليل , جعفر , يوسف , رمهان , ابا عمر , رضوان , عبد الرحمن هاشم , ابو الاء , علي المصري , راعى الغنم , اخر الارض ] على وجه الخصوص واختص اصحاب البرامج اومن قدم يد العون والمساعده فى تطويرها والاضافة اليها نظام المستخدمين الخاص بالاستاذ مهند العبادى تعديل العبد الفقير الى الله اضافة التحكم بالعناصر لكل مستخدم ضمن نظام المستخدمين الاستاذ ابو خليل تصغير القاعدة بجوار الساعه مع الاحتفاظ بأيقونة الاكسس عند التكبير على شريط المهام وعدم ظهور الاطار عند الضغط عليها الاستاذ ناصر - تعديل الاستاذ ابا عمر البحث والفلترة وتظليل ناتج البحث ---- الأستاذ رمهان والاستاذ اباعمر اخفاء اطار الاكس نهائيا - الاستاذ ابا عمر http://im56.gulfup.com/0Q9Ybe.jpg اهاا نسيت شئ اسم كل مستخدم هو نفسه الباسورد لفتح القاعده المرفق بعد تعديل عناوين الراوبط ليشمل كل من تنسيق اوفيس 2000-2003 Access Loge in Hide Win2000-2003.rar وتـــــــــنسيق اوفيس 2007-2013 Access Loge in Hide Win 2007-2013.rar << تم تحديث الروابط (الإدارة) >>

سلمت يمناك ..... كتر الف خيرك

وعليكم السلام ورحمة الله تعالى وبركاته تطبيق على مثالك =IF(AND(A1>=1;A1<=20);1;IF(AND(A1>=21;A1<=31);2;""))

تفضل اخي الكريم نسخة ١ نسخة ٢

ادن جرب الكود التالي ربما يؤدي المطلوب Sub test() Dim WS As Worksheet: Set WS = ActiveSheet Dim pages As Integer pages = WS.Range("C10") With WS .PageSetup.PrintArea = "$B$2:$D$7" .PrintOut Copies:=pages, Collate:=True End With End Sub نموذج طباعة 3.xlsm

تصحيح خطأ كان عند النقر على أحد حقلي التاريخ Y1 + Y2 تقويم.accdb

جرب هدا على ما اظن بعد تعيين حدود الطباعة بالشكل الدي يناسبك Sub test() ActiveSheet.PrintOut Copies:=ActiveSheet.Range("c10").Value, IgnorePrintAreas:=False End Sub

تفضل اخي الكريم الملف كما تريد ارجو الرد بعد الاطلاع عليه test1.rar

Option Explicit Public Property Get WSData() As Worksheet: Set WSData = Sheets("ورقة1") End Property Public Property Get WSDest() As Worksheet: Set WSDest = Sheets("ورقة2") End Property '***' اظافة مربعات الاختيار عند التحقق من وجود قيمة في عمود الاسم Sub Add_CheckBoxes() Dim cell, col As Single, Cpt As CheckBox Dim MyLeft, MyTop, MyHeight, MyWidth As Double Application.ScreenUpdating = False col = WSData.Range("B" & Rows.Count).End(xlUp).Row WSData.CheckBoxes.Delete For cell = 2 To col If WSData.Cells(cell, "B").Value <> "" Then MyLeft = Cells(cell, "A").Left: MyTop = Cells(cell, "A").Top MyHeight = Cells(cell, "A").Height: MyWidth = Cells(cell, "A").Width WSData.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select With Selection .Caption = "": .Value = xlOff: .Display3DShading = False End With [A1].Select End If Next cell Application.ScreenUpdating = True End Sub '**** نسخ الاعمدة المحددة Sub CopyRows() Dim derlig&, r&, Lr&, Cpt As CheckBox For Each Cpt In WSData.CheckBoxes If Cpt.Value = 1 Then For r = 1 To Rows.Count If Cells(r, 1).Top = Cpt.Top Then With WSDest .Range("A2:A" & Rows.Count).ClearContents Lr = .Range("B" & Rows.Count).End(xlUp).Row + 1 ' عمود الاسم .Range("B" & Lr) = _ WSData.Range("B" & r).Value 'في حالة الرغبة بنسخ عدة اعمدة قم بظبط السطر التالي بما يناسبك ' .Range("B" & Lr & ":F" & Lr) = _ ' WSData.Range("B" & r & ":F" & r).Value '**** تسلسل البيانات المنسوخة derlig = WSDest.Range("B" & WSDest.Rows.Count).End(xlUp).Row WSDest.Range("A2").Value = 1 WSDest.Range("A2:A" & derlig).DataSeries , xlDataSeriesLinear End With Exit For End If Next r End If Next On Error Resume Next WSData.CheckBoxes.Value = False On Error GoTo 0 End Sub Microsoft Excel Worksheet جديد (2).xlsm

اخي العبيدي ...لتلافي هذه المشكلة ..اجعل الرقم المعرف...رقم تسلسلي ..يعني autoNumber اما نوع عملة قبض السند فاعمل بها جدول ..بالدينار او الدولار مع رقم تسلسلي ...واعمل منها كومبوبوكس في النموذج حقل ال sand لا تحتاجه في هذا الجدول

الاخ الفاضل صلاح الاكسيس بيتعامل مع كل سجل على حدا يعنى الاحداث بتحصل على مستوي السجل وبالتالى لتنفيذ طلبك هيكون عن طريق عمل جدول مؤقت لحفظ كل البيانات او التغيرات ومن ثم ترحيلها الى الجدول الاساسي

إذا كنت تريد عدم الطباعة يمكن كتابة احد الصيغ التالية وبجوار End sub نكتب 30 On Error Resume Next ActiveWindow.SelectedSheets.PrintOut Copies:=Range("a1"), Collate:=True, _ IgnorePrintAreas:=True أو If Range("a1") = 0 Then GoTo 30 ActiveWindow.SelectedSheets.PrintOut Copies:=Range("a1"), Collate:=True, _ IgnorePrintAreas:=True End If واذا كنت تريد طباعة نسخة على الاقل يمكنك كتابة التالي If Range("a1") = 0 Then ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _ IgnorePrintAreas:=True Else ActiveWindow.SelectedSheets.PrintOut Copies:=Range("a1"), Collate:=True, _ IgnorePrintAreas:=True End If

جرب بعد تعديل a1 بالخليه الى محتاج تحط فيها الرقم النسخ بتاعك ActiveWindow.SelectedSheets.PrintOut Copies:=Range("a1"), Collate:=True, _ IgnorePrintAreas:=True