طالب مدرسة أوفيسنا

الف شكر استاذ ياسر 

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

اتمنى لك التوفيق

اقوم بعمل مدونه تاريخيه للاحداث واربطها بالتواريخ الميلادي والهجري والعبري او بمعنى اخر اسلامي مسيحي يهودي

ولان الاحدث كثيره بالالف صعب التحويل يدوي لذلك اعود لاكسيل

المطلوب بالمرفقات22.rar

الف شكر استاذ ياسر تم المطلوب

احتاج اعرف القيمه اللي استخدمتها للعربيه في الكود مثلا اريد اغيرها بالصينية تايون كمثال

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

تم تحويل التاريخ من الميلادي للهجري المشكلة لم انسخ العمود لملف txt يعود للتاريخ الميلادي

ويكون واضح ان التاريخ تحول فقط كواجهه ولما تنظر لشريط الصيغه تجده بالتنسيق القديم الميلادي 

المطلوب ان يتم تحويل التاريخ للهجري حتى في شريط الصيغه او عند نسخه لملف txt

ارجوا الحل مع الشكر

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

في ١٠‏/٦‏/١٤٣٧ هـ at 17:36, ياسر خليل أبو البراء said:

 

Sub Test()
    Dim A, I As Long, II As Long

    A = Sheets("ALL").Cells(1).CurrentRegion.Value

    With CreateObject("Scripting.Dictionary")
        For I = 1 To UBound(A, 1)
            If Not .exists(A(I, 1)) Then
                .Item(A(I, 1)) = .Count + 1
                For II = 1 To UBound(A, 2)
                    A(.Count, II) = A(I, II)
                Next
            Else
                If A(I, 3) > A(.Item(A(I, 1)), 3) Then
                    For II = 2 To UBound(A, 2)
                        A(.Item(A(I, 1)), II) = A(I, II)
                    Next II
                ElseIf A(I, 3) = A(.Item(A(I, 1)), 3) Then
                    A(.Item(A(I, 1)), 2) = Application.Min(A(.Item(A(I, 1)), 2), A(I, 2))
                End If
            End If
        Next
        I = .Count
    End With

    Sheets("DATA").Cells(1).Resize(I, UBound(A, 2)).Value = A
End Sub

 

 

تعم تعديل الكود بحيث يظهر عام 2015 على حده بشكل بطريقة بدائية

امل ان يكون واضح بالمرفقات

مثال.rar

الله يجزاك خير نعم اريد التعديل لفلترت التاريخ مثلا عام 2015 فقط

بمعنى مشتروات العميل فقط لعام واحد واستخراج الاعلى لها نفس الطريقه السابقه

استاذ ياسر هل ممكن شرح لهذا الكود

حاولت ولم افهم طريقة التصفية ولا عكس استعمالك للداله Min

الكود محترف واريد فهم طريقته

ماشاء الله كود جميل تم به المطلوب

اكرر شكري لك استاذ ياسر

الأقدم في التاريخ

الف شكر استاذنا الغالي ياسر

لامشكله الاكتفاء بالاول منها

السلام عليكم تحيه طيبه للجميع

بإختصار بيانات يتم تصفيتها باسماء العملاء ويتم استخراج اعلى قيمة للعميل بعد التصفيه بإستخدام دالة SUBTOTAL وتعمل بشكل جيد

المطلوب استخراج تاريخ اعلى قيمة

مرفق المثال وشرح المطلوب بشكل واضح وشرح داخل الماكرو لطريقة عمله

مع الشكر

مثال.rar

الف شكر لكل من حاول المساعده

مشرفنا الغالي ياسر 

كود رائع ومحترف تم به المطلوب

السلام عليكم

كما في العنوان مطلوب كود اصغر قيمة لنطاق متغير

مرفق الملف

 اصغر قيمة.rar

الأخ الكبير الغالي بن عليه

بارك الله فيك وجزيت خير الجزاء .. أنت السهل الممتنع لا حرمنا الله منك أبداً

 

الأخ إكس يرجى تغيير اسم الظهور للغة العربية

تقبل تحياتي

مشكور مشرفنا الغالي على التنبيه

تم التعديل ولكم جزيل الشكر

مشكور استاذي العزيز نعم هذا هو المطلوب

السلام عليكم

المعادلة مقارنة بين تاريخين ويقوم بستخراج اقل قيمه في الفتره المعادلة لاتعطي الحل الصحيح

INDEX($A$21:$E$600;SMALL(IF((C21:C600>O5)*(O6>C21:C600);ROW(E21:E600));1);COLUMN(E1)

تم تغيير SMALL ب MIN  ولازالة نفس المشكله

 نموذج للمطلوب بالمرفقات

مع الشكر

نموذج.rar

تسلم اخوي الصقر

يبدو اني لم اوصل الفكره بالشكل الصحيح

المطلوب ليس اختصار للكود فقط ايضا للعمليات مثل العمود G و H اريد الاستغناء عنها هي تقوم بالفرز في حال تطابق مع الشرط يكتب "تنفيذ" وفي حال عدم التطابق يعوض بصفر

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

مع الشكر

لرفع

السلام عليكم ،،، وجمعة مباركه على الجميع

بختصار // هذا الكود يقوم بالفلتره بواسطة عملية حسابيه

Sub Macro1()
Dim lr As Long
Application.ScreenUpdating = False
lr = Range("b" & Rows.Count).End(xlUp).Row
    Range("G18").FormulaR1C1 = "=MAX(R[1]C[-4]:R65536C3)"
    Range("H18").FormulaR1C1 = "=IF(RC[-4]>RC[-1],""تنفيذ"",)"
    Range("G18:H18").AutoFill Destination:=Range("G18:H" & lr), Type:=xlFillDefault
    Range("G18:H" & lr) = Range("G18:H" & lr).Value
    Application.ScreenUpdating = True
End Sub

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

Private Sub CommandButton1_Click()

Dim Cl As Range
If [H17] = "" Then Exit Sub
For Each Cl In Range("H18:H" & [H5000].End(xlUp).Row)
If Cl.Value = [H17] Then
Cl.Offset(0, -6).Resize(1, 3).Copy
Range("N" & [N5000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
MsgBox "تم الترحيل بنجاح ", vbOKOnly, "تنبيه"
End Sub

المطلوب اختصار العملية والاستغناء عن الفلتره ونقل العملية الحسابية لزر الترحيل بحيث يقوم بالحساب وترحيل مايوافق الشروط والاستغناء عن مالاتنطبق عليه الشروط

مع الشكر مرفق للتوضيح

نموذج1.rar

مشكور استاذ سليم

نعم هذا المطلوب

اكرر شكري لك وللقائمي على هذا المنتدى

مرفق المطلوب بشكل واضح

مع الشكرنموذج2.rar

المطلوب تعديل بستبدال خلية الشرط G1  بكلمة "تنفيذ" بمعنى يبحث داخل العمود اذا وجد كلمة "تنفيذ" يرحل

الكود يعمل بشكل جيد مع البيانات القليله ولما اضع تقريبا 3000 صف الكود لاينفذ ويعطي مسج تم الترحيل وهو غير صحيح

اعتقد بناء الكود بشكل مختلف يحل المشكله مع الشكر

Dim Cl As Range

If [G1] = "" Then Exit Sub
For Each Cl In Range("O21:O" & [O6000].End(xlUp).Row)
If Cl.Value = [G1] Then
Cl.Offset(0, -14).Resize(1, 7).Copy
Range("R" & [R6000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
MsgBox "تم الترحيل بنجاح ", vbOKOnly, "تنبيه"
End Sub