طباعة اختيار خامة معينة

[mohamedyousef]

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

السادة الاعزاء 

محتاج عند اختيار صنف معين يقوم الكود بطباعة الصنف المختار فقط وتجميع القيم في اخر الصفحة وذلك الاعمدة المطلوبة A,E,R,S,T طبعا الطباعة الى اخر صنف موجود في الاخيار والصفحة المطلوبه هي صفحة التكويد

مع الشكر

80.xlsm

اسف المطلوب موجود على فورم رقم 8 

[mohamedyousef]

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

السادة الكرام ارفق لحضراتكم ملف اذا كنت اريد طباعة خامة معينة مثلا 

 ( كروشيه ) بجميع مقاساته والوانه مثل :

ابيض كروشيه 1.2cm
ابيض CO-IMG-40 كروشيه 4cm
ابيض فلاش كروشيه 2cm
اسود كروشيه 4.5cm

وذلك من صفحة التكويد اريد ان اطبع فقط خامة مثلا الكروشيه بالوانها ومقاساتها العمود (A,E,R,S,T) وموجود زر الطباعة على فورم رقم 8   فهل في الامكان عمل هذا مع الشكر لكل من يقوم بمساعدتي مع الاخذ في الاعتبار طباعة الصفحات الموجود بها المطلوب مع حاصل جمع في اخر الطباعة من كل (وزن كيلو - متر -وعدد قطع)

81.xlsm

[أبوأحـمـد]

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

Private Sub CommandButton1_Click()
Dim LRow As Long
Dim namsh As String
Dim wk, wk2 As Worksheet
Dim x As Integer
Dim check As Boolean
namsh = "temp"
Set wk = Worksheets("التكويد")

    'التأكد من عدم وجود الورقة المؤقته وإضافتها

For Each wk2 In Worksheets
If wk2.Name Like namsh Then check = True: Exit For
Next
If check = False Then

    With ThisWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh
    End With
  
 End If
  
'ترحيل الصفوف المختارة
Set wk2 = Worksheets(namsh)
 wk2.Range("A1:E9999") = ""
 LRow = wk.Range("A999").End(xlUp).Row

wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1")

With wk2
'إضافة المجاميع في الصف الأخير
Rowz = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & Rows(Rows.Count).End(xlUp).Row))
.Range("B" & Rowz + 2) = "الاجمالي"
.Range("C" & Rowz + 2) = "=ROUND(SUM(C2:C" & Rowz + 1 & "),2)"
.Range("D" & Rowz + 2) = "=ROUND(SUM(D2:D" & Rowz + 1 & "),2)"
.Range("E" & Rowz + 2) = "=ROUND(SUM(E2:E" & Rowz + 1 & "),2)"
.Columns("A:E").AutoFit

'تنسيق الصف الأخير الخاص بالمجموع

'
 With wk2.Range("B" & Rowz + 2 & ":E" & Rowz + 2)
     .AddIndent = True
.Font.FontStyle = "Times New Roman"
    .Font.Size = 16
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Interior.Color = RGB(237, 237, 220)
    
      
    .Font.Bold = False
  .Font.Bold = True
  End With
   

   .PageSetup.PrintArea = "A1:E" & Rowz + 2 'LRow
    Application.Dialogs(xlDialogPrint).Show

End With
 
 
 '
 
    Application.DisplayAlerts = False
    
    'التأكد من وجود الورقة المؤقته وحذفها
        If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub
        If Evaluate("=ISREF('" & namsh & "'!A1)") Then
            Sheets(namsh).Delete
        End If
    Application.DisplayAlerts = True
 
End Sub

'عمل فلتر على محتوى الكمبوبوكس
Private Sub CommandButton2_Click()
With Worksheets("التكويد").Range("A1:T1")
'إلغاء الفلتر
  If ActiveSheet.AutoFilterMode Then
     ActiveSheet.AutoFilterMode = False
  End If
If Me.ComboBox1.Text = "" Then Exit Sub
.AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text '& "*"
End With

'استدعاء الطباعة
Call CommandButton1_Click

'إلغاء الفلتر
  If ActiveSheet.AutoFilterMode Then
     ActiveSheet.AutoFilterMode = False
  End If


End Sub


'ملء الكمبوبوكس بأسماء السلع بعد حذف التكرار
Private Sub UserForm_Activate()
  If ActiveSheet.AutoFilterMode Then
     ActiveSheet.AutoFilterMode = False
  End If
Dim wk As Worksheet
Set wk = Worksheets("التكويد")
Dim v, e

LRow = wk.Range("A999").End(xlUp).Row
v = wk.Range("C2:C" & LRow).Value

With CreateObject("scripting.dictionary")
    .comparemode = 1
    For Each e In v
        If Not .exists(e) Then .Add e, Nothing
    Next
    If .Count Then Me.ComboBox1.List = Application.Transpose(.keys)
End With
End Sub

 

81.xlsm

[mohamedyousef]

السلام عليكم اخي العزيز

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

واعتزر للقائمين على المنتدى مرة اخرى والسلام عليكم ورحمة الله