نبيل عبد الهادي

مثال 

New Microsoft Excel Worksheet_2.xlsm

ضع الكود التالي في حدث كل ورقة من الاوراق الاربعة

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If Target.Address = Range("A46").Address Then
Button1_Click
 End If
End Sub

Sub Button1_Click()
   Dim ws As Worksheet
   WkSheets = Array("ورقة1", "ورقة2", "ورقة3", "ورقة4")
   
   For Each ws In Sheets(Array("ورقة1", "ورقة2", "ورقة3", "ورقة4"))
   
      ws.Select
      Range("b46:n46").Formula = "=SUM(B3:B43)"
  Range("b47:n47").Formula = "=SUM(B7:B13,B27,B32)"
  Range("n2:n44").Formula = "=SUM(B2:m2)"
  
   Next ws
End Sub

غير  المصفوفه باسماء الاوراق الاربعة لديك

تفضل

ملف_تطبيق_الجمع_بشروط.xlsm

بعد اذن استاذ سليم 

تم تعديل رؤوس الاعمدة التي تمثل عناوين الجدول  ليتم اضافتها في كل ورقة جديدة 

عمل الكود:

1- هل  تريد  تحويل الصفوف الى اوراق جديدة ؟  اختر نعم

2- ادخل عدد الصفوف

3- هل تريد تضمين صف العناوين ؟ احتر نعم 

ملاحظه

- في الملف المرفق 1080 صف ويمثل عدد الاسماء .. سيتم انشاء  108 شيت !!

 - دمج  الخلايا سيؤدي الى اخطاء في الكود

تقسيم 2.xlsm

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

المعادلة :-

النقد الفعلي في الخزينة = ( صافي النقد في الخزينة ( اجمالي التمويل + اجمالي الايرادات  -  اجمالي المصروفات  )) + ( اجمالي العهد )

يومية خزينة2020.xlsm

تفضل

ملاحظه اي تغير في موضع الخلايا المستهدفه في اوراق المقاولات ستكون النتائج خاطئة

11 - Copy.xlsm

الكود يعمل وحسب ماطلبت مطابقة / وفلترة/ ترحيل المكرر بين القائمتين مع الصف ( بشرط ان تكون القائمة في العمود A هي الاساس) الى ورقة اخرى

اما اذا كنت تقصد ان لايكون اللصق في اخر صف فارغ

جرب المرفق في ورقة3

111112.xlsm

حل رائع استاذ محمد

وهنا حل اخر المطايقة وترحيل المكرر الى ورقة اخرى 

111112.xlsm

تفضل

العمال.xlsm

مجرد الاختيار من القائمة يتم تعبئة العمود b  تلقائي

المطلوب.xlsm

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

1- فيما يخص رسالة التاكيد قبل تفريغ البيانات تم اجراء اللازم

2- فيما يخص الفلترة نفس السبب المشار اليه في المشاركة الاولى يجب عليك اعداد ورقة السجل على هذا الاساس 

3- في الملف مرجع دائري او اكثر ابحث عنها وصحح المعادلات

نسخة للتعديل.xlsm

الكود يعمل على اساس اللصق بعد اخر صف يحوي بيانات ... وعلى اساس  كانت لديلك بيانات اسفل الجدول "عناوين"يتم اعتباراها اخر صف والترحيل بعدها

مطلوب تعديل كود الترحيل.xlsm

تفضل

وعلى فرض ان      "pass = "123

ترحيل وطباعة المحدد.xls

على الرغم ان بعض ماطلبته مبهم وغير واضح

تفضل الملف المرفق

orginalcopy-protcet - Copy.rar

لم استطع تحميل الملف المرفق 

ضع الكود التالي في  module

الحفظ الافتراضي سيكون في  Desktop بعد اختيار اسم للملف المصدر 

Public Sub Save_Range_As_PDF_On_Desktop()

    Dim fileName As String, saveAsFileName As Variant
    Dim PDFrange As Range
    With Sheets("sheet13")
        Set PDFrange = .Range("a1:j286")
    End With
    saveAsFileName = Application.GetSaveAsFilename(InitialFileName:=Get_SpecialFolderPath("Desktop") & fileName, _
                        FileFilter:="PDF file (*.pdf), *.pdf", _
                        Title:="Save PDF file")
    If saveAsFileName <> False Then
        PDFrange.ExportAsFixedFormat Type:=xlTypePDF, fileName:=saveAsFileName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End If
End Sub
Private Function Get_SpecialFolderPath(SpecialFolderName As Variant) As String
    Get_SpecialFolderPath = CreateObject("WScript.Shell").SpecialFolders(SpecialFolderName) & "\"
End Function

تفضل 

1- حدد بالماوس انطاق  "C3:P3"

2- نفذ الكود

3- اختيار yes

4- الملفات المصدرة بصيغة txt ستحفظ في مجلد الملف الرئيسي

Enquiry.rar

تفضل

ملف رقم 1تجربة 1.xlsb ملف رقم 2تجربة 1.xlsb

تم حل مشكلة الفلترة مع اضافة تنسيق التاريخ الى  combobox

سيتم تصدير الورقة  FilteredData الى مجلد الملف الاصلي كملف جديد مع امكانية اختيار اسم لهذا الملف

test.rar

تفضل ادخل على هذه الروابط  علها تنفعك

https://www.officena.net/ib/topic/59074-ماهي-الدالة-لاضافة-5-درجات-القرار-المدرسة/

https://www.officena.net/ib/topic/41369-مساعدة-في-اضافة-درجات-للطالب/

تفضل 

ونفس ملاحظاتي في مشاركتي الاخير

master_file.xlsm MyFolder.rar

تفضل .. 

مجرد تنشيط "الورقة1" يتم النسخ

المصنف1_2.xlsm

بعد الاطلاع على الملف المرفق

تكون المعادلة بهذا الشكل

=IFERROR(VLOOKUP(M9;H7:I16;2;FALSE);"")

تطابق تام  FALSE