احمد بدره

تم تعديل المطلوب

المصنف1(3)(1).xlsx

تفضل المطلوب

المصنف1(3).xlsx

جرب هذا التعديل ربما يكون ما تريده

 Sub Macro01()

a = MsgBox("هل  تريد طباعة الان  ؟", vbYesNo + vbQuestion, "طباعة")

' اذ اخترت لا اريد الطباعة الصحيح الكود يقف ويلغي التنفيذ هنا
If a = vbYes Then
With ActiveSheet
Dim Numcop As Integer
         Numcop = Application.InputBox("أدخل عدد النسخ للطباعة:", "كم عدد النسخ?", 1, Type:=1)
        If Numcop = 0 Then
        Exit Sub
        ElseIf Len(Numcop) > 0 Then
        End If
        a = MsgBox("هل  تريد طباعة الان  ؟", vbYesNo + vbQuestion, "طباعة")
If a = vbNo Then
 Exit Sub

 Else
     ActiveWindow.SelectedSheets.PrintOut copies:=Numcop
 'اذ اخترت لا اريد الطباعة  عدد الصحيح الكود يقف ويلغي التنفيذ كذالك  هنا
 End If
End With
End If
    
  Dim X3 As Long, X4 As Long
X3 = Sheets("DATA").Range("a1000").End(xlUp).Row + 1
X4 = Sheets("aaa").Range("B24").End(xlUp).Row
   Sheets("DATA").Range("B" & X3).Resize(X4 - 5, 21) = Sheets("aaa").Range("B6").Resize(X4 - 5, 21).Value
 
End Sub

الملف يعمل بشكل ممتاز

ممكن أن تقوم بحفظ الملف بنوع مصنف به وحدات ماكرو ممكنة ربما يكون هذا هو الحل الأول

إذا لم يحدث اذهب إلى لوحة التحكم واختر إضافة وإزالة برامج يظهر لك صندوق حوارى به أسماء البرامج المثبتة

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

قم بنقل هذا الكود

           Application.ScreenUpdating = False

في صدر الماكرو  بعد

On Error GoTo 1

فأعتقد يكون أسرع

قم بتجربة هذا التعديل على كود حضرتك وأتمنى من الله أن يكون هذا هو المطلوب

Sub Macro01()

a = MsgBox("هل  تريد طباعة الان  ؟", vbYesNo + vbQuestion, "طباعة")

' اذ اخترت لا اريد الطباعة الصحيح الكود يقف ويلغي التنفيذ هنا
If a = vbYes Then
With ActiveSheet
Dim Numcop As Integer
         Numcop = Application.InputBox("أدخل عدد النسخ للطباعة:", "كم عدد النسخ?", 1, Type:=1)
        If Numcop = 0 Then
        Exit Sub
        ElseIf Len(Numcop) > 0 Then
        End If
     ActiveWindow.SelectedSheets.PrintOut copies:=Numcop
 'اذ اخترت لا اريد الطباعة  عدد الصحيح الكود يقف ويلغي التنفيذ كذالك  هنا
 
End With
End If
    
  Dim X3 As Long, X4 As Long
X3 = Sheets("DATA").Range("a1000").End(xlUp).Row + 1
X4 = Sheets("aaa").Range("B24").End(xlUp).Row
   Sheets("DATA").Range("B" & X3).Resize(X4 - 5, 21) = Sheets("aaa").Range("B6").Resize(X4 - 5, 21).Value
 
End Sub

جرب هذا الكود لعله يفي بالغرض  في حالة الوافقة يظهر صندوق حواري لكتابة رقم أول صفحة في الطباعة  اكتب رقم البداية ثم اضغط ok

يظهر صندوق حواري لكتابة رقم آخر صفحة في الطباعة اكتب رقم النهاية ثم اضغط ok

Sub طباعةمدىمن_الصفحات()

A = MsgBox("هل  تريد طباعة الان  ؟", vbYesNo + vbQuestion, "طباعة")

' اذ اخترت لا اريد الطباعة الصحيح الكود يقف ويلغي التنفيذ هنا
If A = vbYes Then
Dim startpage As Integer
Dim endpage As Integer
startpage = InputBox("من فضلك أدخل رقم أول صفحة المراد طباعتها.", " رقم أول صفحة في الطباعة")
If Not WorksheetFunction.IsNumber(startpage) Then
MsgBox "Invalid Start Page number. Please try again.", "Error"
Exit Sub
End If
endpage = InputBox("من فضلك أدخل رقم آخر صفحة المراد طباعتها.", "رقم آخر صفحة في الطباعة ")
If Not WorksheetFunction.IsNumber(endpage) Then
MsgBox "Invalid End Page number. Please try again.", "Error"
Exit Sub
End If
ActiveWindow.SelectedSheets.PrintOut From:=startpage, To:=endpage, Copies:=1, Collate _
:=True
End If
    
  Dim X3 As Long, X4 As Long
X3 = Sheets("DATA").Range("a1000").End(xlUp).Row + 1
X4 = Sheets("aaa").Range("B24").End(xlUp).Row
   Sheets("DATA").Range("B" & X3).Resize(X4 - 5, 21) = Sheets("aaa").Range("B6").Resize(X4 - 5, 21).Value
 
End Sub

تفضل الشرح في المرفق

وإليك الملف مجمع

تجميع الملفين.rar

اتبع الخطوات التي بالمرفق ربما تأتي بالحل

تفضل الملف بعد التعديل ليفتح لك على صفحة الفاتورة وتقوم بتشغيل الفورمة من الزر الذي قمت بعمله

امكانية ادخال البيانات والفورمة ظاهرة.rar

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

تفضل الكود  مع ملاحظة أن المعاينة والطباعة لموظف واحد فقط

 Sub PrintAll()

    Dim LastR As Integer

   Sheets("بيانات اساسية").Select

   LastR = Sheets("بيانات اساسية").Cells(Rows.Count, "B").End(xlUp).Row

    Range("B6:B" & LastR).Select

    x = Application.WorksheetFunction.CountA(Selection)

  Sheets("مفردات").Select

    Range("A6").Select

    Selection.ClearContents

    For I = 1 To x

    Range("A6") = I

    ActiveWindow.SelectedSheets.PrintPreview

    Next I

    End Sub

يوجد خطأ في كتابة التاريخ  بعمود تاريخ الزيارة بالرقم 8 في الشيتين مكتوب هكذا  5/15/2018  والصحيح   15/05/2018 قم بالتعديل وجربها أيضًا على الفورم ربما يكون هذا هو الخطأ 

أفضل الطرق في اعتقادي الذي قدمتها لك  لأنها

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

إضافة إلى ذلك أنها تعمل في أي ورقة عمل نشطة

ومرتبطة بأن تكون خلية العمود c غير فارغة

وصراحة كل أعضاء المنتدى لا يبخلون على أحد بأي معلومة

كلمة المرور : 12345

من فضلك اتبع الخطوات التي في الصورة  الشكل رقم 1 في الملف القديم  وباقي الأشكال تتبع في الملف الجديد

مع خالص تحياتي

تم تعديل الكود ليتناسب مع كل الأعمدة ابتداءًا من العمودM إلى العمودCV كل ما عليك هو وضع رقم الدرجة للنهاية الصغرى في الصف رقم 9 للأعمدة المطلوب وضع دوائر لها

الشرط الثاني لوضع الدوائر هو أن يكون نطاق خلايا العمود c في الصفوف غير فارغ

-1استبدال التظليل بدوائر حمراء.xlsm

تسلم الأنامل

تفضل الملف وبعد إذن الأستاذ علي لإثراء الموضوع تم عمل كود إضافة الدوائر وكود حذف الدوائر بزر أمر واحد

فعندما تضغط على زر حذف الدوائر يتم حذفها ويظهر الزر باسم إضافة الدوائر والعكس صحيح

ولإثراء الموضوع أيضًا تم تعديل آخر في الكود وهو جعل الماكرو يعمل بأي صفحة عمل تكون نشطة

-1استبدال التظليل بدوائر حمراء.xlsm

تفضل المرفق وكود لإضافة سطر فارغ في الملف

استبدال التظليل بدوائر حمراء.xlsx

تفضل الملف المرفق لعله يفي بالغرض

Picture Lookup.xlsx

اتبع خطوات المرفق

تفضل المرفق أخي الفاضل ويمكن أن تغير النسبة المئوية كما تريد

Microsoft Office Excel Worksheet جديد _(3)_.rar

قم بإيقاف هذا السطر وذلك بوضع علامة التنصيص "

أو قم بحذفه

فباقي الأكواد تعمل بدونه وتعUserform.xlsطي النتيجة المطلوبة

ممكن بهذه الطريقة

معادلة جمع.xlsx

لا يشترط وأنا جربت بنفسي العربية السعودية كمثال