أبومروان

وعليكم السلام ورحمه الله وبركاته يمكنك الافضل استخدام PivotTable TEST.xlsm TEST.xlsm

السلام عليكم ورحمه الله

طيب ما ممكن نخلي مثلا صوره الطباعه في خليه B1 وعنمل اضافه تعليق علي الخليه لعله يفيد حضرتك

اليك حل اخر بالاكواد لعله يفيد حضرتك وممكن تعدل عليه علي حسب رغبه حضرتك Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim hijriDate As String ' تعيين الورقة النشطة Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير اسم الورقة إذا كان مختلفًا ' التحقق إذا كان التغيير في النطاق X3 إلى آخر خلية تحتوي على بيانات If Not Intersect(Target, ws.Range("X3:X" & ws.Cells(ws.Rows.Count, "X").End(xlUp).Row)) Is Nothing Then ' العثور على آخر صف يحتوي على بيانات في العمود X lastRow = ws.Cells(ws.Rows.Count, "X").End(xlUp).Row ' تكرار عبر الصفوف من X3 إلى آخر صف For i = 3 To lastRow ' قراءة التاريخ الهجري من الخلية hijriDate = ws.Cells(i, "X").Value ' التحقق إذا كانت الخلية تحتوي على تاريخ If hijriDate <> "" Then ' التحقق إذا كان حرف "هـ" موجودًا بالفعل If InStr(hijriDate, "هـ") = 0 Then ' تحويل التاريخ إلى التنسيق المطلوب وإضافة حرف "هـ" ws.Cells(i, "X").Value = Format(hijriDate, "yyyy/mm/dd") & "هـ" End If End If Next i End If End Sub مثل التاريخ.xlsm

السلام عليكم ورحمه الله وبركاته يمكنك استخدام صيغة. إليك كيفية القيام بذلك: في خلية فارغة، أدخل التاريخ بالتنسيق 1446/05/01. في خلية أخرى، استخدم الصيغة التالية =TEXT(A1, "yyyy/mm/dd") & "هـ" حيث A1 هي الخلية التي تحتوي على التاريخ. اضغط على Enter. ستظهر النتيجة بالتنسيق 1446/05/01هـ. إذا كنت تفضل، يمكنك أيضًا إدخال التاريخ مباشرة مع "هـ" كما يلي: اكتب في الخلية: 1446/05/01هـ. لكن تذكر أن ذلك سيعطي Excel نصًا وليس تاريخًا، لذلك ستفقد بعض وظائف التاريخ. استخدام الصيغة هو الخيار الأفضل إذا كنت تحتاج إلى التعامل مع التواريخ بشكل أكبر

وعليكم السلام ورحمه الله وبركاته ممكن تستخدم HYPERLINK زسيظهر لك كما في الصور ادناه. ارجو ان يكون المطلوب وليك الشرح 1/232/ wor.xlsm wor.xlsm

وعليكم السلام ورحمه الله بعد اذن استاذنا @عبدالله بشير عبدالله يسعدني أن أشارك معكم هذه التجربة في محاولة مني للمساهمة والتفاعل الإيجابي والاستفاده من حضرتكم. Sub نقل_الأعمدة() Dim wsSource As Worksheet Dim wsFirst As Worksheet Dim wsSecond As Worksheet Dim wsThird As Worksheet Dim lastRow As Long ' تعيين ورقة المصدر Set wsSource = ThisWorkbook.Sheets("الرئيسية") ' تعيين أوراق العمل الأخرى Set wsFirst = ThisWorkbook.Sheets("الأولى") Set wsSecond = ThisWorkbook.Sheets("الثانية") Set wsThird = ThisWorkbook.Sheets("الثالثة") ' العثور على آخر صف في ورقة المصدر lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row ' نقل الأعمدة إلى الورقة الأولى wsSource.Range("A1:A" & lastRow).Copy wsFirst.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("D1:D" & lastRow).Copy wsFirst.Range("B1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("F1:F" & lastRow).Copy wsFirst.Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AB1:AB" & lastRow).Copy wsFirst.Range("D1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AC1:AC" & lastRow).Copy wsFirst.Range("E1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' نقل الأعمدة إلى الورقة الثانية wsSource.Range("A1:F" & lastRow).Copy wsSecond.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AT1:AT" & lastRow).Copy wsSecond.Range("G1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' نقل الأعمدة إلى الورقة الثالثة wsSource.Range("A1:A" & lastRow).Copy wsThird.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("D1:D" & lastRow).Copy wsThird.Range("B1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("F1:F" & lastRow).Copy wsThird.Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("Q1:Q" & lastRow).Copy wsThird.Range("D1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("R1:R" & lastRow).Copy wsThird.Range("E1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats wsSource.Range("AB1:AR" & lastRow).Copy wsThird.Range("F1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats ' تنظيف الحافظة Application.CutCopyMode = False MsgBox "تم نقل الأعمدة بنجاح!", vbInformation End Sub

وعليكم السلام ورحمه الله

وعليكم السلام ورحمة الله تعالى وبركاته بعد إذن السادة الأفاضل، يسعدني أن أشارك معكم هذه التجربة في محاولة مني للمساهمة والتفاعل الإيجابي والاستفاده من حضرتكم. Sub CalculateH23() Dim ws As Worksheet Dim countNonEmpty As Long Dim result As Variant Set ws = ThisWorkbook.Sheets("Sheet1") ' احسب عدد الخلايا غير الفارغة في النطاق B11:I15 countNonEmpty = Application.WorksheetFunction.CountA(ws.Range("B11:I15")) ' تحقق من الشرط في الخلية F23 If ws.Range("F23").Value = "الأول" Or ws.Range("F23").Value = "الثاني" Then result = Application.WorksheetFunction.Min(25, countNonEmpty) ElseIf ws.Range("F23").Value = "الثالث" Then result = countNonEmpty Else result = "" End If ' وضع النتيجة في الخلية H23 ws.Range("H23").Value = result End Sub

وعليكم السلام ورحمه الله وبركاته

وعليكم السلام ورحمه الله وبركاته ممكن ترفق شيت اكسل فيه المطلوب

والسلام عليكم باركالله فيك عمل اكثر من رائع ممكن تشرح الاكواد للاستفاده اكتر

السلام عليكم ورحمه الله وبركاته عمل اكثر من رائع ومجهود كبير جعله الله فى ميزان حسناتك في الانتظار النسخه النهائيه والكثير

السلام عليكم ورحمة الله وبركاته ممكن تتسخدم المعادله ادناه لعله يكون المطلوب =IF(WEEKDAY(DATE($F$2,$E$2, ROW(A1)))=6, "", IF(WEEKDAY(DATE($F$2, $E$2, ROW(A1)))=7, "", DATE($F$2, $E$2, ROW(A1)))) أيام الشهر من يوم محدد.xlsx

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

وعليكم السلام ورحمه الله وبركاته يمكنك استخدام هذا التنسيق لعله يكون المطلوب

وعليكم السلام جرب الكود التالي لعله يفيد حضرتك ولعله المطلوب Sub Export_PDF() Dim SH As Worksheet, R As Range, File_name As String Set SH = ThisWorkbook.Worksheets("Sheet3 (2)") File_name = SH.Range("p8").Value Set R = SH.Range("A1:x35") R.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & File_name End Sub 6666.xlsm 118.pdf

ممكن تستخدم الاكواد الاتيه للاخفاء الصفوف واظهارها Sub اخفاء() Dim Cl As Range For Each Cl In Range("a3:a103") If Cl.Value = Range("k2") Then Cl.EntireRow.Hidden = True End If Next Cl End Sub Sub اظهار() Dim Cl As Range For Each Cl In Range("a3:a103") If Cl.Value = Range("k2") Then Cl.EntireRow.Hidden = False End If Next Cl End Sub

HID_SH.rar

أ/ @رشاد احمد ارفقت لحضرتك في المشاركه السابقه الملف جاهز عندالتغير سوف يتم استدعاء المطلوب وحول تقرا الموضع هيفيدك ويساعدك للوصول لافضل حل وفهم الكود

وعليكم السلام ورحمه وبركاته جرب المرفق لعله الملطلوب تم الاستعانه بالموضوع ادناه السيارات 24.xlsm ودا الكود المستخدم عدل عليه براحتك حسي الاحتياج Sub Trans_Data() '????? ??? ???????? ???? ?????? '????? ???? '?? ??? ????? ?? 15/11/2017 '????? ?? ????? ?? ??????? ???? ????? ???? '================ Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '??????? ?? ????? ???????' Dim Main As Worksheet, sh As Worksheet ' ??????? ?? ?????????? Dim Arr As Variant, Temp As Variant '(i,j)??????? ?? ????? ???????? ?????? ( p ) ????? ???????? ??????? Dim i As Long, j As Long, p As Long ' ??????? ?? ??????? ???? ??? ??? ????? ???? Dim dep As String Set Main = Sheets("1") Set sh = Sheets("2") '======= ' ??? ??????? ??????? sh.Range("A5:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents ' ????? ???????? dep = sh.Range("e2").Value ' ???????? ?????? Arr = Main.Range("A3:AC" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value ' ????? ???????? ????? ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) ' ??? ???????? ?????? For i = 1 To UBound(Arr, 1) '??? ???? ????? If Arr(i, 4) Like "*" & dep & "*" Then 'If Arr(i, 101) = dep Then ' ?????? ?????? ??? ???????? ????? p = p + 1 ' ??? ???????? ????? For j = 1 To UBound(Arr, 2) ' ????? ???????? ????? ?? ???????? ?????? ??? ????? Temp(p, j) = Arr(i, j) Next End If Next ' ???? ??????? ????? ????? '??? ???????? ???????? If p > 0 Then sh.Range("A5").Resize(p, UBound(Temp, 2)).Value = Temp sh.Range("A5:AC" & Rows.Count).Borders.Value = 0 '??? ?????? ??????? sh.Range("A5:AC" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _ .Weight = xlMedium ' .Weight = xlThin ' .Weight = xlMedium ' .Weight = xlThick Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

وعليكم السلام ورحمه الله راجع الرابط ادناه للاستاذ @أ / محمد صالح اكثر من رائع لعله بفيدك

السلام عليكم ورحمه الله

والسلام عليكم ورحمة الله وبركاته