كل الانشطه

وعليكم السلام ورحمة الله تعالى وبركاته =TEXT((A4-INT(A4))*1000,"000")

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

السلام عليكم ورحمة الله وبركاته المطلوب استخراج الكسور من العدد المدون في العمود A وكتابة في العمود C مثال : في الخلية A4 القيمة العددية : 1796.630 والمطلوب كتابة 630 بطريقة آلية ( باستخدام المعادلات أو الأكواد ) في الخلية C4 الملف المرفق يوضح يطريقة أفضل تجربة_فصل الكسور من العدد في خلية مستقلة.xlsx

وعليكم السلام ورحمة الله وبركاته .. في مرفقك ، الورقة "MD1 15-2020-16" موجودة في الأساس ، وأنت تريد ترحيل البيانات اليها مسبقاً ، ثم تريد انشاء نسخة من الورقة Main بنفس الاسم الموجود في الخلية B2 في Main صحيح !!!! وضحها اذا سمحت 😅

تفضل أخي الكريم ، محاولتي البسيطة . حيث في الورقة الثانية = موقف الغياب اليومي ، قمت بإضافة زر للتحديث ، وتم استدعاءه للدالة التي تم انشاؤها في مديول عام :- Sub ExtractAbsentEmployees() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim targetDate As Date Dim dayNum As Integer Dim targetCol As Integer Dim lastRow As Long Dim i As Long Dim reportRow As Long Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب اليومي") wsReport.Range("A5:D" & wsReport.Rows.Count).ClearContents targetDate = wsReport.Range("C2").Value dayNum = Day(targetDate) targetCol = 3 + dayNum If targetCol < 4 Or targetCol > 34 Then MsgBox ".تاريخ غير صالح يجب أن يكون اليوم بين 1 و 31", vbExclamation Exit Sub End If lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 5 For i = 4 To lastRow If wsMain.Cells(i, targetCol).Value = "غ" Then wsReport.Cells(reportRow, 1).Value = wsMain.Cells(i, 1).Value wsReport.Cells(reportRow, 2).Value = wsMain.Cells(i, 2).Value wsReport.Cells(reportRow, 3).Value = wsMain.Cells(i, 3).Value wsReport.Cells(reportRow, 4).Value = targetDate reportRow = reportRow + 1 End If Next i If reportRow = 5 Then MsgBox "لا يوجد موظفين متغيبين في هذا التاريخ", vbInformation End If End Sub وفي الورقة الثالثة "موقف الغياب الشهري" ، أيضاً تم انشاء زر لاستدعاءه الدالة التالية من نفس المديول :- Sub GenerateMonthlyAbsenceReport() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim startDate As Date, endDate As Date Dim currentDate As Date Dim dayNum As Integer, targetCol As Integer Dim lastRow As Long, reportRow As Long, i As Long Dim empName As String, empJob As String Dim dateList As String, dayList As String Dim dateCount As Integer Dim dayName As String Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب الشهري") If Not IsDate(wsReport.Range("C2").Value) Or Not IsDate(wsReport.Range("C3").Value) Then MsgBox "الرجاء إدخال تاريخين صالحين في الخلايا C2 و C3", vbExclamation + vbMsgBoxRight, "" Exit Sub End If startDate = wsReport.Range("C2").Value endDate = wsReport.Range("C3").Value If startDate > endDate Then MsgBox "خطأ: تاريخ البداية يجب أن يكون قبل تاريخ النهاية", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With wsReport .Range("A6:F" & .Rows.Count).ClearContents .Range("6:" & .Rows.Count).RowHeight = 15 End With lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 6 For i = 4 To lastRow empName = wsMain.Cells(i, 2).Value empJob = wsMain.Cells(i, 3).Value If empName = "" Then GoTo NextEmployee dateList = "" dayList = "" dateCount = 0 currentDate = startDate Do While currentDate <= endDate dayNum = Day(currentDate) targetCol = 3 + dayNum If targetCol >= 4 And targetCol <= 34 Then If wsMain.Cells(i, targetCol).Value = "غ" Then dayName = wsMain.Cells(2, targetCol).Value If dateList <> "" Then dateList = dateList & vbLf & Format(currentDate, "yyyy-mm-dd") dayList = dayList & vbLf & dayName Else dateList = Format(currentDate, "yyyy-mm-dd") dayList = dayName End If dateCount = dateCount + 1 End If End If currentDate = DateAdd("d", 1, currentDate) Loop If dateCount > 0 Then With wsReport .Cells(reportRow, 1).Value = reportRow - 5 .Cells(reportRow, 2).Value = empName .Cells(reportRow, 3).Value = empJob .Cells(reportRow, 4).Value = dateCount .Cells(reportRow, 5).Value = dateList .Cells(reportRow, 6).Value = dayList .Cells(reportRow, 5).WrapText = True .Cells(reportRow, 6).WrapText = True If dateCount > 1 Then .Rows(reportRow).RowHeight = 15 * dateCount End If End With reportRow = reportRow + 1 End If NextEmployee: Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If reportRow > 6 Then ' MsgBox "تم إنشاء التقرير بنجاح", vbInformation + vbMsgBoxRight, "" Else MsgBox "لا توجد أيام غياب في الفترة المحددة", vbInformation + vbMsgBoxRight, "" End If End Sub وتركت لك التعديل متاحاً من خلال تحديد الصف أو العمود ... إلخ . وهذا ملفك بعد التعديل . راجعه وأخبرنا بالنتيجة .. موقف غياب موظفين.zip

مرفق الملف شهر 12022.zip

السلام عليكم ورحمة الله وبركاته اخواتي في الله مطلوب كود يقوم بترحيل المكتوب في شيت Main في الخليه C8 الى اسم الشيت المكتوب في الخليه B2 يقوم بترحيلها بالترتيب في العمود B6 ثم يقوم بنسخ شيت NEW وفتح شيت جديد باسم الخليه B2 في شيت Main وان امكن ان يعمل ربط تشعبي اذا امكن تطبيقها على الملف المرفق جعله الله في موازين حسناتكم BB.xlsm

المشكلىة الملف كبير فيه تقريبا 20 الف صف وحجمه كبير هذا صورة من بيانات الملف price الكمية الصنف التاريخ 0.850 70 خيار 01-Jan-22 0.075 42 جرجير 01-Jan-22 0.850 232 خيار 01-Jan-22 0.850 30 خيار 01-Jan-22 1.000 23 باذنجان 01-Jan-22 1.000 13 كزبرة 01-Jan-22

من الأفضل رفع ملف ليتم العمل عليه

تفضل Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long, startRow As Long Dim r As Long, i As Long, j As Long Dim values(1 To 7) As Variant Dim count As Long Dim data As Variant On Error GoTo ErrorHandler Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي startRow = 3 ' الصف الذي تبدأ منه البيانات lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' تنظيف التنسيقات السابقة من الأعمدة C:I و O With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow) .Interior.ColorIndex = xlNone .Font.ColorIndex = xlAutomatic .Font.Bold = False End With ' تحميل النطاق إلى مصفوفة data = ws.Range("C" & startRow & ":I" & lastRow).Value ' المرور على كل صف For r = 1 To lastRow - startRow + 1 ' تخزين قيم الصف الحالي For i = 1 To 7 values(i) = data(r, i) Next i ' فحص القيم الفريدة For i = 1 To 7 count = 0 If Not IsEmpty(values(i)) Then For j = 1 To 7 If CStr(values(j)) = CStr(values(i)) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة If count = 1 Then ' تطبيق التنسيق على الخلية في C:I With ws.Cells(r + startRow - 1, i + 2) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف With ws.Cells(r + startRow - 1, "O") .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With End If End If Next i Next r MsgBox "تمت معالجة البيانات بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub

لدى جدول مكون من التاريخ والكمية والصنف وسعر العبوة واريد استخراج تقرير لكل شهر لاعلى قيمة لكل صنف حسب الشهر حسب الأشهر 1 2 3 4 5 6 7 8 9 10 11 12 طماطم فلفل حلو خيار خس بروكلى كزبرة ملفوف بقدونس باذنجان لوبيا اشبنت نعناع

تحويل الدالة الى دالة عامة ، يتم استدعائها في أي نموذج ، توسيع الفكرة اختيار التاريخ لا يعمل بشيت b-c-d.xlsm

هذا الكود الصحيح بخصوص تنسيق الاعمدة المختلفة من العمود C حتى العمود I هل يمكن اضافة ودمج كود خاص بتنسيق العمود المحدد فى العمود O Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long Dim r As Long Dim values(1 To 7) As Variant ' لتخزين القيم من C إلى I (7 أعمدة) Dim i As Integer, j As Integer Dim count As Integer ' 1. إعدادات ورقة العمل Set ws = ThisWorkbook.Sheets("Sheet1") ' ?? غيّر "Sheet1" إلى اسم ورقتك الفعلي ' 2. تحديد آخر صف يحتوي على بيانات في العمود C lastRow = ws.Cells(ws.Rows.count, "C").End(xlUp).Row ' 3. تنظيف أي تنسيقات سابقة من الأعمدة C إلى I ' هذا مهم لضمان تطبيق التنسيقات الجديدة فقط ws.Range("C3:I" & lastRow).Interior.ColorIndex = xlNone ' مسح لون التعبئة ws.Range("C3:I" & lastRow).Font.ColorIndex = xlAutomatic ' مسح لون الخط المخصص ws.Range("C3:I" & lastRow).Font.Bold = False ' إلغاء الخط العريض ' 4. المرور على كل صف بدءًا من الصف 3 (أو أي صف تبدأ منه بياناتك) For r = 3 To lastRow ' ابدأ من الصف الذي تبدأ منه بياناتك ' قراءة القيم من العمود C إلى I للصف الحالي وتخزينها في مصفوفة ' Column C is index 1 (i + 2 where i=1 means 1+2=3 which is C) For i = 1 To 7 values(i) = ws.Cells(r, i + 2).Value ' i+2 لأن C هو العمود الثالث Next i ' فحص كل قيمة في الصف لتحديد إذا كانت فريدة داخل هذا الصف For i = 1 To 7 ' تكرار على كل عمود من C إلى I (بواسطة فهرس المصفوفة i) count = 0 ' إعادة تعيين العداد لكل قيمة ' مقارنة القيمة الحالية (values(i)) بجميع القيم الأخرى في نفس الصف For j = 1 To 7 If values(j) = values(i) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة (تكررت مرة واحدة فقط في الصف) If count = 1 Then ' تطبيق التنسيق على الخلية المحددة التي تحتوي على القيمة الفريدة With ws.Cells(r, i + 2) ' i + 2 يمثل رقم العمود الفعلي (C, D, E...) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء (RGB for exact yellow) .Font.Color = RGB(255, 0, 0) ' خط أحمر (RGB for exact red) .Font.Bold = True ' خط عريض End With End If Next i Next r ' إذا كنت لا تزال ترغب في الاحتفاظ بالعمود O بالنص الوصفي، يمكنك ترك الكود الخاص بك ' Sub CheckDifferences() وتشغيله بعد هذا الكود، أو دمج المنطق هنا. ' لكن هذا الكود يركز فقط على تنسيق الخلايا من C إلى I. End Sub

قد سبقني السباقون الأساتذة .. ما شاء الله عليهم .. عذراً للتأخر في الرد ، ولكن يبدوا أنهم قد أجادوا بما طرحوا ، ويسعدني نقلك للإجابة لأي حل آخر تراه مناسباً لك ( بصدر رحب طبعاً ) .

معلمي الفاضل ، اعتذر عن التأخر بالرد ، ولكن فعلاً تفاجأة بضيوفي من العائلة 😅 ولوقت متأخر لم أتمكن من المتابعة ,, على العموم ، وبما انك رأيت ان فكرة الحقلين هي الأنسب لك والأوفر والأقل جهداً ، قد يكون قرارك صائباً برؤية أبعد .. على العموم بانتظار مرفقك المعدل ، ومتابع معك .

ممتاز اخواتي الكرام شكرا استاذ حجازي والف شكر استاذي الفاضل محمد هشام جعله الله في موازين حسناتكم

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

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

بعد إذن أساتذتي حل بالمعادلات بشكل مبسط BB (3).xlsx

للرفع

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الخلية G2 ضع المعادلة التالية مع سحبها للأسفل =IFERROR(IF(G$6="قوى", IF(INDIRECT("'"&F$6&"'!L"&ROW()) <>"", INDIRECT("'"&F$6&"'!L"&ROW()), ""), IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!O"&ROW())<>"", INDIRECT("'"&F$6&"'!O"&ROW()), ""), "")),"") الخلية G2 =IFERROR(IF(G$6="قوى",IF(INDIRECT("'"&F$6&"'!M"&ROW()) <>"", INDIRECT("'"&F$6&"'!M"&ROW()), ""),IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!P"&ROW())<>"", INDIRECT("'"&F$6&"'!P"&ROW()), ""),"")),"") وفي خلية F6 ====> أسماء أوراق العمل يمكنك إتباع الخطوات التالية لجلب أسماء أوراق العمل للقائمة المنسدلة بشكل ديناميكي =OFFSET(F!$B$6, 0, 0, COUNTIF(F!$B$6:$B$10000, "<>"), 1) =NameWS BB.xlsx

اخي الكريم هل من الممكن ان تكون معادله وليس كود ؟ بارك الله لك في علمك ومجهودك وحفظك الله من كل شر

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

وعليكم السلام ورحمة الله وبركاته ,, حاولت فهم المطلوب بشكل واضح ، وخرجت بهذه الفكرة . حيث انشأت زر للتنفيذ ، يحتوي الكود التالي :- Private Sub Btn_1_Click() Dim wsMain As Worksheet Dim wsTarget As Worksheet Dim lastRow As Long Dim i As Long Dim targetCol1 As String, targetCol2 As String Dim sourceCol1 As String, sourceCol2 As String Set wsMain = ThisWorkbook.Sheets("F") Dim targetSheetName As String targetSheetName = wsMain.Range("F6").Value On Error Resume Next Set wsTarget = ThisWorkbook.Sheets(targetSheetName) On Error GoTo 0 If wsTarget Is Nothing Then MsgBox " : الورقة المحددة غير موجودة" & targetSheetName, vbExclamation + vbMsgBoxRight, "" Exit Sub End If If wsMain.Range("G6").Value = "قوى" Then sourceCol1 = "L" sourceCol2 = "M" targetCol1 = "H" targetCol2 = "I" ElseIf wsMain.Range("G6").Value = "تامين" Then sourceCol1 = "O" sourceCol2 = "P" targetCol1 = "H" targetCol2 = "I" Else MsgBox "يجب اختيار 'قوى' أو 'تامين' في الخلية G6", vbExclamation + vbMsgBoxRight, "" Exit Sub End If wsMain.Range("H6:I" & wsMain.Rows.Count).ClearContents lastRow = wsTarget.Cells(wsTarget.Rows.Count, sourceCol1).End(xlUp).Row lastRow = Application.WorksheetFunction.Max(lastRow, wsTarget.Cells(wsTarget.Rows.Count, sourceCol2).End(xlUp).Row) For i = 6 To lastRow If wsTarget.Range(sourceCol1 & i).Value <> "" Then wsMain.Range(targetCol1 & (i - 0)).Value = wsTarget.Range(sourceCol1 & i).Value End If If wsTarget.Range(sourceCol2 & i).Value <> "" Then wsMain.Range(targetCol2 & (i - 0)).Value = wsTarget.Range(sourceCol2 & i).Value End If Next i MsgBox "تم نقل البيانات بنجاح", vbInformation + vbMsgBoxRight, "" End Sub جرب المرفق وأخبرنا بالنتيجة .. BB.zip

متابعه