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

السلام عليكم تفضل الملف اتمنى ان يكون فيه طلبك الكود Private Sub ListBox1_Change() Dim selectedCount As Integer Dim i As Long selectedCount = 0 For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then selectedCount = selectedCount + 1 End If Next i Label8.Caption = "عدد الصفوف المحددة: " & selectedCount End Sub بالتوفيق الملف ListBox - SelectCount.xlsm

يمكن ذلك ولكن يلزم اخراج مصدر التقرير ليصبح استعلاما ظاهرا لوجود معايير به يلزم ان تسبق تجميع الارصدة stock17 .rar

جرب هدا Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range Dim choose As VbMsgBoxResult, DataRng As Range, Cnt As Boolean Set WS = Sheets("ورقة1") Set DataRng = WS.Range("A1:E50") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row Cnt = False For i = 3 To lastRow If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then Cnt = True Exit For End If Next i If Not Cnt Then MsgBox "لا توجد بيانات مطابقة للحذف", vbExclamation, "خطأ" Exit Sub End If choose = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") Application.ScreenUpdating = False If choose = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If Next i If Not OnRng Is Nothing Then OnRng.Delete For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i MsgBox "تم حذف الصفوف بنجاح", vbInformation, "الحذف" With WS .PageSetup.TopMargin = .PageSetup.BottomMargin = .PageSetup.LeftMargin = .PageSetup.RightMargin = Application.InchesToPoints(0.5) .[C1].Value = Format(Date - 1, "dd/mm/yyyy") .[B1].Value = Format(Date - 1, "dddd") End With With DataRng.Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" End If Application.ScreenUpdating = True End Sub مثال1 v2.xlsm

DC.xlsx

شكر استاذي العزيز Barna على المساعدة الله يجعلها في ميزان حسناتك كما نتمنى من إدارة المنتدي تصحيح العنوان لانه به اخطاء

تفضل ...................... Public Function CheckInkhirat(ByRef ID As Integer) As String On Error GoTo err_CheckInkhirat Dim yearNow As Integer Dim totalPaid As Currency Dim paymentMarch As Boolean Dim paymentJuly As Boolean ' تحديد السنة الحالية yearNow = Year(Date) ' إجمالي المبلغ المدفوع ' totalPaid = Nz(DSum("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow), 0) totalPaid = Nz(DSum("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow & " AND Loan_ID = 0"), 0) ' التحقق من دفع المبلغ في مارس ويوليو paymentMarch = Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow & " AND Month(Auto_Date) = 3"), 0) = 1500 paymentJuly = Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & yearNow & " AND Month(Auto_Date) = 7"), 0) = 1500 ' التحقق من الشروط If totalPaid = 3000 And paymentMarch = False And paymentJuly = False Then CheckInkhirat = "عزيزي العامل، يمكنك الاستفادة من جميع الامتيازات لأنك دفعت مبلغ الانخراط كاملاً." ElseIf totalPaid = 3000 And paymentMarch = True And paymentJuly = True Then CheckInkhirat = "عزيزي العامل، يمكنك الاستفادة من جميع الامتيازات لأنك دفعت مبلغ الانخراط كاملاً على دفعتين." Else CheckInkhirat = "عزيزي العامل، لا يمكنك الاستفادة من الامتيازات لأنك لم تدفع مبلغ الانخراط." End If Exit Function err_CheckInkhirat: MsgBox "خطأ رقم " & Err.Number & ": " & Err.Description, vbCritical, "خطأ" CheckInkhirat = "حدث خطأ أثناء التحقق من بيانات الانخراط." End Function

مشكلتك في الفرز انت عملت الفرز في التقرير حسب التاريخ .. والكود تعامل معه على هذا الاساس .. طيب ما المشكلة لما تفرز حسب المعرف ... هو نفسه سوف يفرزه حسب التاريخ بل هو ادق بحيث لو تاريخين متشابهين راح يجيب لك الذي تم تسجيله اولا ويضعه في الأعلى --------------------------------------------------------------------------------- كود الرصيد يعتمد على معرف الجدول (id) وهو تلقائي غير قابل للتكرار والتاريخ مؤكد سوف يتجدد حسب السجل الجديد بمعنى ان اي تاريخ يتم تسجيله كجديد سوف يكون التاريخ اكبر من الذي قبله أو مساويا له الكود لا ينظر للتاريخ وانما ينظر للمعرف ويتعامل معه من الاصغر الى الأكبر اكبر دليل لما تكون فاتح نموذج التقارير وتختار المواد الغذائية والبطاطا .. افتح الاستعلام وانظر stock19 .rar

شكراً جزيلاً أستاذ عبدالله بارك الله فيك وزادك الله علماً ومعرفة .

السلام عليكم بعد اذن استالذنا أبومروان حل بواسطة المصقوفات الكود Sub ذكرين_انثيين() Dim ws As Worksheet Dim lastRow As Long Dim dataArray As Variant Dim males() As Variant Dim females() As Variant Dim resultArray() As Variant Dim maleCount As Long, femaleCount As Long Dim rowIndex As Long, i As Long, j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row dataArray = ws.Range("A2:F" & lastRow).Value ReDim males(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) ReDim females(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) maleCount = 0 femaleCount = 0 For i = 1 To UBound(dataArray, 1) If dataArray(i, 6) = "ذكر" Then maleCount = maleCount + 1 For j = 1 To UBound(dataArray, 2) males(maleCount, j) = dataArray(i, j) Next j ElseIf dataArray(i, 6) = "انثى" Then femaleCount = femaleCount + 1 For j = 1 To UBound(dataArray, 2) females(femaleCount, j) = dataArray(i, j) Next j End If Next i ReDim resultArray(1 To maleCount + femaleCount, 1 To UBound(dataArray, 2)) rowIndex = 1 i = 1 j = 1 Do While i <= maleCount Or j <= femaleCount For k = 1 To 2 If i <= maleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = males(i, col) Next col rowIndex = rowIndex + 1 i = i + 1 End If Next k For k = 1 To 2 If j <= femaleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = females(j, col) Next col rowIndex = rowIndex + 1 j = j + 1 End If Next k Loop For i = 1 To UBound(resultArray, 1) resultArray(i, 1) = i ' الترقيم يبدأ من 1 Next i ws.Range("A2:F" & lastRow).ClearContents ws.Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray MsgBox "تم الترتيب بنجاح !", vbInformation End Sub الملف فرز حسب الجنس بشروط.xlsb

وعليكم السلام ورحمه الله وبركاته اتفضل لعله المطلوب Sub CustomSortByGender() Dim ws As Worksheet Dim lastRow As Long Dim maleList As Collection, femaleList As Collection Dim i As Long, rowIndex As Long Dim gender As String Dim maleRow As Long, femaleRow As Long ' تحديد الورقة النشطة (تأكد من تعديل الاسم إذا لزم الأمر) Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من أن اسم الورقة صحيح ' تحديد آخر صف في العمود A (الذي يحتوي على بيانات) lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' إنشاء مجموعات لتخزين الذكور والإناث Set maleList = New Collection Set femaleList = New Collection ' تصنيف البيانات في العمود F إلى مجموعات الذكور والإناث For i = 2 To lastRow ' بدءًا من F2 gender = ws.Cells(i, "F").Value If gender = "ذكر" Then maleList.Add i ' إضافة رقم الصف إلى قائمة الذكور ElseIf gender = "أنثى" Then femaleList.Add i ' إضافة رقم الصف إلى قائمة الإناث End If Next i ' إعادة ترتيب البيانات في العمود F حسب التكرار المطلوب rowIndex = 2 ' نبدأ من F2 Do While maleList.Count > 0 Or femaleList.Count > 0 ' إضافة 2 ذكر If maleList.Count >= 2 Then maleRow = maleList(1) ws.Rows(maleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll maleList.Remove 1 maleList.Remove 1 rowIndex = rowIndex + 1 maleRow = maleList(1) ws.Rows(maleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll maleList.Remove 1 rowIndex = rowIndex + 1 ElseIf maleList.Count = 1 Then maleRow = maleList(1) ws.Rows(maleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll maleList.Remove 1 rowIndex = rowIndex + 1 End If ' إضافة 2 أنثى If femaleList.Count >= 2 Then femaleRow = femaleList(1) ws.Rows(femaleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll femaleList.Remove 1 femaleList.Remove 1 rowIndex = rowIndex + 1 femaleRow = femaleList(1) ws.Rows(femaleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll femaleList.Remove 1 rowIndex = rowIndex + 1 ElseIf femaleList.Count = 1 Then femaleRow = femaleList(1) ws.Rows(femaleRow).Copy ws.Rows(rowIndex).PasteSpecial Paste:=xlPasteAll femaleList.Remove 1 rowIndex = rowIndex + 1 End If Loop End Sub فرز حسب الجنس بشروط.xlsm فرز حسب الجنس بشروط.xlsm

Update: تصحيح بعض الاخطاء 1- عمل قائمة ازرز لاختيار الخط 2- اعتماد تعين خصائص التقرير من غير جدول ================================= هل يوجد مقترح بتعديل على عرض التقرير او التصميم او طريقة افضل منها ☕ ====================================( Video ) Update_Fix_Open_MenuShortClick_ReportAfterPrint_On_Form_Ms_Access.rar

أنا متأكد ان الحلبي يسأل من اجل حماية نفسه .. وبياناته .. من باب العلم عن نفسي ومن باب التعلم حاولت مع امتداد mdb ونجحت ولم اقدر على accdb .. لذا اعتبرها اكثر أمانا

وعليكم السلام -على الرغم انك لم تقم برفع ملف موضح فيه كل المطلوب الا انك يمكنك استخدام هذا Public Function XLookup(ByVal vTable As Variant, _ ByVal vResult As Variant, _ ParamArray vKeyVals() As Variant) As Variant Const cRoutine As String = "XLookup" Dim oLo As ListObject 'Table containing data Dim vKeys As Variant 'vKeyVals internal version Dim sCol As String 'Column Address Range to search Dim vKey As Variant 'Key(s) to find in Column(s) Dim lKey As Long 'Current key Dim lRow As Long 'Found Row Dim lCol As Long 'Found Column Dim sAddTxt As String 'Additional Error Text ' Error Handling Initialization On Error GoTo ErrHandler Set XLookup = Nothing ' Check Inputs and Requisites ' Table Select Case TypeName(vTable) Case Is = "ListObject": Set oLo = vTable Case Is = "Range": Set oLo = vTable.ListObject Case Else: Set oLo = ActiveSheet.Evaluate(vTable).ListObject End Select ' Return Column If TypeName(vResult) = "Range" Then vResult = vResult.Value2 ' Search Keys If UBound(vKeyVals) = -1 Then Err.Raise DspError, , "#Key(s) required" ' When called by VBA, ParamArrays sometimes are stuffed in the first element If IsArray(vKeyVals(LBound(vKeyVals))) Then _ vKeys = vKeyVals(LBound(vKeyVals)) Else _ vKeys = vKeyVals ' Procedure With oLo If Not .DataBodyRange Is Nothing Then ' Just 1 key - Use Worksheet.Function because it is fastest w/1 Key If LBound(vKeys) = UBound(vKeys) Then vKey = vKeys(UBound(vKeys)) If IsNumeric(vKey) Then vKey = CDbl(vKey) lRow = Application.WorksheetFunction.Match( _ vKey, _ .ListColumns(1).DataBodyRange, _ 0) ' More than 1 key - Use Worksheet.Evaluation because it is fastest w/multiple keys Else ' Concatenate Key Values and Search Column Addresses For lKey = LBound(vKeys) To UBound(vKeys) lCol = lCol + 1 sCol = IIf(sCol <> vbNullString, sCol & " & ", vbNullString) & _ .ListColumns(lCol).DataBodyRange.Address ' Determine Key Value If TypeName(vKeys(lKey)) = "Range" Then _ vKey = vKey & vKeys(lKey).Value2 Else _ If IsDate(vKeys(lKey)) Then _ vKey = vKey & CLng(vKeys(lKey)) Else _ vKey = vKey & vKeys(lKey) Next ' Find Row # by Evaluating MATCH within the Table's worksheet lRow = .Parent.Evaluate("=Match(""" & vKey & """," & sCol & ",0)") End If ' Get Column # lCol = .ListColumns(vResult).Index ' Return result Set XLookup = .ListRows(lRow).Range(lCol) End If End With ErrHandler: If Err.Number > 0 Then ' Create sAddTxt (Additional Error Text) if needed Select Case Err.Number Case Is = 9: sAddTxt = "Column " & vResult & " not found in " & oLo.Name Case Is = 13, 1004: sAddTxt = "Key(s) " & Join(vKeys, ",") & " not found" Case Is = 424: sAddTxt = "Table not found" End Select ' Customize Errors based on UDF of VBA caller If TypeName(Application.Caller) = "Range" Then 'Called from UDF MLookup = CVErr(xlErrRef) Debug.Print cRoutine & ":" & Err.Description & vbLf & sAddTxt Else 'Called from VBA (most likely) Select Case Err.Number Case Is = 13, 1004: 'Key(s) not found. Log Error Debug.Print cRoutine & Err.Description & vbLf & sAddTxt Case Else: 'Pop Up Error Message Select Case DspErrMsg(cModule & "." & cRoutine, sAddTxt) Case Is = vbAbort: Stop: Resume 'Debug mode - Trace Case Is = vbRetry: Resume 'Try again Case Is = vbIgnore: 'End routine End Select End Select End If End If End Function أو يمكنك مشاهدة هذا الرابط Custom Excel XLOOKUP Function أو هذا الرابط UDF: XLOOKUP – Using VLOOKUP for left AND right searches وهذا ايضا فيديو للشرح https://www.youtube.com/watch?v=Tbqh4_HcUlI

بعد اذن استاذ حسين مامون جرب هذا الملف لعله يفى بالغرض قوائم اعلام الطلاب االفصل االثاني 2018-2019 --1.xls

السلام عليكم ورحمة الله اخى العزيز ضع هذين الكودين معا فى موديول واحد واربط الكود الاول بزر التحكم عسى الله ان يكون هذا هو المطلوب ملحوظة صغيرة : الكود قد يستغرق بعض الوقت للتنفيذ Sub Calling_Data() LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row LS = Sheet2.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For R = 2 To LR For S = 2 To LS If Cells(R, "A") = Sheet2.Cells(S, "B") Then If Cells(R, "B") = Sheet2.Cells(S, "A") Then Cells(R, "E") = Sheet2.Cells(S, "C") Cells(R, "F") = Sheet2.Cells(S, "D") End If End If Next Next Application.ScreenUpdating = True Call Calling2_Data End Sub Sub Calling2_Data() LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row LS = Sheet3.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For R = 2 To LR For S = 2 To LS If Cells(R, "A") = Sheet3.Cells(S, "B") Then If Cells(R, "B") = Sheet3.Cells(S, "A") Then Cells(R, "C") = Sheet3.Cells(S, "D") Cells(R, "D") = Sheet3.Cells(S, "E") End If End If Next Next MsgBox "Êã ÇáÊÑÍíá ÈäÌÇÍ " Application.ScreenUpdating = True End Sub

انظر الى المرفق كنموذج من 20 اسم sample salim.rar

أخي الكريم أبو حمادة يبدو لي أنك تقوم بتغييرات في الكود .. مما يتسبب في حدوث مشاكل إليك الملف المرفق التالي لم يتم فيه تنفيذ الكود .. يعني نسخة أصلية كما أرفقتها في مشاركة سابقة .. جرب الملف وأعطي ملاحظاتك !! انقر على صورة "إنا فتحنا لك فتحاً مبيناً" ... لو فيه أية ملاحظات يرجى ذكر ملاحظة واحدة فقط .. وتذكر كيف حدثت المشكلة ؟ أي ما هي الإدخالات التي سببت المشكلة؟ لن ارفق أكواد .. سأرفق ملف مرفق وأمري لله Filter Data By Dates & Transfer Skipping Formula Rows YasserKhalil.rar تم تعديل الملف المرفق .. دعك من الإصدار الأول للملف ..جرب الملف التالي (الإصدار الثاني) حيث اكتشفت بعض الأخطاء وتمت معالجتها إن شاء الله Filter Data By Dates & Transfer Skipping Formula Rows YasserKhalil V2.rar

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أحياناً ما تحدث بعض المشاكل عند التعامل مع النوافذ الموجودة في محرر الأكواد .. كأن تختفي نافذة أو تتحرك نافذة من مكانها الذي تعودنا عليه ، وعند محاولة إرجاعها إلى مكانها لا نستطيع .. أنا مؤمن بمبدأ : بدلاً من تضييع الوقت في محاولة ترقيع الثوب المهلهل .. عليك بشراء ثوب جديد .. (وفر وقتك وفلوسك واحصل على نتيجة أفضل) أقصد من كلامي بدلاً من الخوض في تفاصيل معرفة حل المشكلة وقد يضيع الوقت في محاولة الحل وفي النهاية قد لا تصل لنتيجة مرضية أو يمكن أن تصل لنتيجة ويحدث خطأ في نقطة أخرى المهم موضوعنا عن كيفية إعادة ضبط إعدادات محرر الأكواد .. 1- اقفل برنامج الإكسيل (أو الأوفيس بشكل عام) 2- روح لقايمة Start في الويندوز ثم الأمر Run واكتب الأمر regedit للدخول إلى ريجستري الويندوز 3- روح لهذا المسار HKEY_CURRENT_USER\Software\Microsoft\VBA\6.0\Common\ بالنسبة للرقم 6 قد يكون مختلف حسب نسخة الويندو سواء كانت 32 بت ستجدها رقم 6.0 أما 64 بت فستجدها 7.1 أو 7.0 4- المهم ادخل على المجلد المسمى Common ، اعمل عليه كليك يمين ثم Delete (جمد قلبك ومتخافش .. لو حصل حاجة أنا مش مسئول) هتخرج لك رسالة تأكد الحذف .. انقر نعم يا بطل ومتخافش ..الويندوز هيسقط بس 5- افتح برنامج الإكسيل .. من لوحة المفاتيح اضغط Alt + F11 لتجد نسخة جديدة من محرر الأكواد (محرر الأكواد في ثوبه الجديد) كأنك لسه منصب أوفيس جديد ****************************** يمكنك إعادة ضبط الإعدادات التي تريدها .. الإعدادات التي أقوم بضبطها بشكل شخصي هي كالتالي : ** بعمل Maximize للنافذة اللي قدامي عشان تكون الصورة أوضح ** من Tools ثم Options أعلم علامة صح على الخيار Require Variable Declaration عشان أضيف السطر الخاص بإجبار المبرمج على الإعلان عن المتغيرات .. السطر دا بيكون شكله كالتالي Option Explicit ** من نفس النافذة أشيل علامة الصح من أول خيار Auto syntax Check عشان وأنا بكتب وغلطت متظهرش رسالة تنبيه بالخطأ ( واحد هيقولي طيب دي خاصية مفيدة .. ماشي كويس بس بتعطلني عن كتابة أسطر الكود ..يكفي أنني أرى السطر باللون الأحمر بعد الانتهاء منه .. هذا تنبيه كافي ) ** من نفس النافذة بدخل على التبويب المسمى Editor Format ثم أغير حجم الخط Size عشان أشوف أسطر الكود بشكل واضح ، ثم أوك في النهاية ** على يمين شريط الأدوات بعمل كليك يمين في مكان فارغ وبختار شريط Edit وبسحب الشريط وأضعه جنب شريط الأدوات القياسي (الموجود بالفعل) وفي نهاية المطاف .. أرجو أن يكون الموضوع (رغم بساطته) أن يكون مفيد لمن يريد التعامل مع محرر الأكواد) تقبلوا وافر تقديري وحبي واحترامي

اخى الفاضل اولا لك منى دعوه طيبه للالتزام بقواعد المنتدى ومنها ان تكون اسماء الظهور باللغه العربيه .............................................................. ثانيا هذه محاوله بسيطه منى ارجو ان تفى بالغرض تقبل تحياتى Private Sub CommandButton2_Click() Application.Visible = True searchE.Hide End Sub Private Sub CommandButton4_Click() Me.PrintForm End Sub Private Sub CommandButton5_Click() searchE.Hide Main.Show End Sub Private Sub Label5_Click() End Sub Private Sub OptionButton1_Click() OptionChange (1) End Sub Private Sub OptionButton2_Click() OptionChange (2) End Sub Private Sub OptionButton3_Click() OptionChange (3) End Sub Sub OptionChange(myOption As Long) Me.ComboBox2.Clear For h = 2 To 9 Me.Controls("textbox" & h).Value = "" Next Select Case myOption Case 1 With Sheets("qs") .Select ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Case 2 With Sheets("q") .Select ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "C").End(xlUp).Row).Value End With Case 3 With Sheets("gar") .Select ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Case 4 With Sheets("dok") .Select ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Case 5 With Sheets("harrr") .Select ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Case 6 With Sheets("owww") .Select ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Case 7 With Sheets("baaaa") ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Case 8 With Sheets("bbbbb") ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With Case 9 With Sheets("qqqq") .Select ComboBox2.List = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value End With End Select End Sub Private Sub OptionButton4_Click() OptionChange (4) End Sub Private Sub OptionButton5_Click() OptionChange (5) End Sub Private Sub OptionButton6_Click() OptionChange (6) End Sub Private Sub OptionButton7_Click() OptionChange (7) End Sub Private Sub OptionButton8_Click() OptionChange (8) End Sub Private Sub OptionButton9_Click() OptionChange (9) End Sub Private Sub TextBox8_Change() TextBox8.Value = Format(TextBox8.Value, "yyyy/mm/dd") End Sub Private Sub TextBox9_Change() TextBox9.Value = Format(TextBox9.Value, "yyyy/mm/dd") End Sub Private Sub ComboBox2_Change() On Error Resume Next If ComboBox2.MatchFound = False Then MsgBox "ÝÖáÇ ÇÎÊÑ ãä ÇáÞÇÆãå": Exit Sub lr = Cells(Rows.Count, "A").End(xlUp).Row Dim a As Range Set ww = Application.WorksheetFunction Set a = Range("A2:z" & lr) Me.TextBox2.Value = ww.VLookup(Me.ComboBox2.Value, a, 2, False) Me.TextBox3.Value = ww.VLookup(Me.ComboBox2.Value, a, 3, False) 'Me.TextBox4.Value = ww.VLookup(Me.ComboBox2.Value, a, 4, False) Me.TextBox5.Value = ww.VLookup(Me.ComboBox2.Value, a, 4, False) Me.TextBox6.Value = ww.VLookup(Me.ComboBox2.Value, a, 8, False) Me.TextBox7.Value = ww.VLookup(Me.ComboBox2.Value, a, 9, False) Me.TextBox8.Value = ww.VLookup(Me.ComboBox2.Value, a, 6, False) Me.TextBox9.Value = ww.VLookup(Me.ComboBox2.Value, a, 7, False) End Sub Private Sub UserForm_Click() End Sub

بارك الله فيك أخي الرائع مختار يمكن استخدام الإضافة التالية لتؤدي الغرض بعد إدراج الإضافة سيظهر زر أمر في التبويب Home باسم Get Sheet Size Get Sheets Size.rar

أهلا بك أستاذ عصام فى أوفيسنا . جرب الكود التالى Sub WorksheetSizes() Dim C As Range, Sh As Worksheet Dim Wb As String, Temp As String, sReport As String Application.ScreenUpdating = False Application.DisplayAlerts = False sReport = "حجم الأوراق" Wb = "mokhtar.xlsx" Temp = ThisWorkbook.Path & Application.PathSeparator & Wb On Error Resume Next Set Sh = Worksheets(sReport) If Sh Is Nothing Then With ThisWorkbook.Worksheets.Add(Before:=Worksheets(1)) .Name = sReport .Range("A1").Value = "اسم الشيت" .Range("B1").Value = "الحجم بالبايت تقريباً" End With End If On Error GoTo 0 With ThisWorkbook.Worksheets(sReport) .Select .Range("A1").CurrentRegion.Offset(1, 0).ClearContents Set C = .Range("A2") End With For Each Sh In ActiveWorkbook.Worksheets If Sh.Name <> sReport Then Sh.Copy ActiveWorkbook.SaveAs Temp ActiveWorkbook.Close SaveChanges:=False C.Offset(0, 0).Value = Sh.Name C.Offset(0, 1).Value = FileLen(Temp) Set C = C.Offset(1, 0) Kill Temp End If Next Sh Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

عموماً بعد عدة محاولات استطعت التغلب على الأمر إليك الملف التالي عله يفي بالغرض Private Sub Worksheet_Change(ByVal Target As Range) Dim X If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 1 And Target.Column = 3 Then Application.EnableEvents = False If IsEmpty(Target.Value) Or IsEmpty(Target.Offset(, -2)) Then Target.Value = "" ElseIf Target.Value = "تر" Then Target.Value = "تعديل راتب" ElseIf Target.Value = "تظ" Then Target.Value = "تظلم" ElseIf Target.Value = "اب" Then Target.Value = "إضافة بيانات" ElseIf Target.Value = "ن" Then Target.Value = "نقل" ElseIf Target.Value = "اخ" Then Target.Value = "إنهاء خدمة" ElseIf Target.Value = "ج" Then Target.Value = "أجازة" Else Target.Value = Target.Value End If Application.EnableEvents = True End If If Target.Row > 1 And Target.Column = 1 Then Application.EnableEvents = False On Error Resume Next X = Target.Value Target.Value = Application.WorksheetFunction.VLookup(Target.Value, Sheet2.Range("A2:C11"), 2, 0) Target.Offset(, 1).Value = Application.WorksheetFunction.VLookup(X, Sheet2.Range("A2:C11"), 3, 0) Application.EnableEvents = True End If End Sub تقبل تحياتي كابتن ماجد VLOOKUP Formula Change Target Value V2.rar

الاستاذ / يوسف تحيه طيبه وبعد ممكن حضرتك تشوف المرفق لعله به الدواء . خط سير عمال.rar

أخي الحبيب // اذا كنت تقصد ان البيانات ثابتة تم الاستغناء عن مصدر البيانات شيت 2 والبيانات كلها من داخل الفورم تفضل بالمرفقات ترحيل مع vlookup.rar

الكثير منا يعاني من الاثار التي تخلفها الفيروسات (غلق الرجستري ، ادارة المهام ، خيارات المجلد ....الخ) و حتى بعد القضاء على الفيروسات فانها ستبقى و لاصلاح ذلك تحتاج الى مثل هذه الادوات ملاحظة : عند التفعيل يجيب تسخيل الخروج و الدخول للمستخدم ايضا هذه الاكواد صالحة لجميع تطبيقات الاوفيس vba tooles.rar