عمل ترحيل من الصفحة الاساسية الى الصفحات

[marwa41]

المطلوب

ترحيل شغل كل مقاول من  الصفحة الرئيسية الى صفحة المقاول توماتيك بكود لرمجى 

فتح صفحة لكل مقاول على حدة 

وعند ادراج اسم مقاول جديد فى صفحة رقم 1  يتم فتح صفحة تلقائى وترحيل بيانات 

وبعد التكرم بالسابق يرجى عدم تكرار التنزيل فى صفحة المقاول  وعدم تكرار  اسم المقاول 

وعند الطباعة يتحول الى صيغة pdf للطباعة

ااجمالى كميات السولار.xlsm

تم تعديل يناير 4, 2021 بواسطه marwa41

[سليم حاصبيا]

بغض الخطوات التي يجب اتباعها قيل تنفيذ الماكرو

الجدول يجب ان يكون مستقلاً غن اي خلايا لا علاقة له بها لذلك
  1- تم  تفريغ الصف رقم 5 من اي شيء واخفاءه (لعدم الكتابة فيه غن طريق الحطأ)
  2- تم  تفريغ العامودين ( D و L ) من اي شيء واخفاءهما (لعدم الكتابة فيهما غن طريق الحطأ)
 3- الماكرو يأخذ بعض الوقت ليكمل عمله (جوالي 10 ثواني -- حسب سرعة الحهاز عندك) لان البيانات كثيرة جداً

 4- الصفحات الأحرى موجودة لكن تم اخفائها لمتابعة عمل الماكرو (بكمن اعادة اظهارها)

الكود

Option Explicit
Dim i%, Lr%, k%
Dim Filer_Rg As Range
Dim Mon_Array(), Itm
'++++++++++++++++++++++++++++++++++++++++
Sub ADD_Sheet()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Tousi3
Lr = .Cells(Rows.Count, "H").End(3).Row
If Lr < 7 Then Exit Sub
 For i = 7 To Lr
  If Application.CountIf(.Range("H2:H" & i), _
    .Range("H" & i)) = 1 Then
     ReDim Preserve Mon_Array(k)
     Mon_Array(k) = .Range("H" & i)
    k = k + 1
   End If
 Next
 
    For i = 7 To Lr
        If Not Application.Evaluate("ISREF('" & _
         .Range("H" & i) & "'!A1)") Then
           Sheets.Add(, Sheets(Sheets.Count)).Name = _
         .Range("H" & i)
        
        End If
    Next
End With

End Sub
'++++++++++++++++++++++++++++++++++++++++
Sub Filter_Please()
ADD_Sheet
Dim Rg As Range, Ro%
Tousi3.AutoFilterMode = False
Set Filer_Rg = Tousi3.Range("E6").CurrentRegion
 For Each Itm In Mon_Array
 Sheets(Itm).Range("B3").CurrentRegion.Clear
 Filer_Rg.AutoFilter 4, Itm
 Filer_Rg.SpecialCells(12).Copy
 With Sheets(Itm).Range("B3")
 .PasteSpecial (8)
 .PasteSpecial (11)
 End With
 Set Rg = Sheets(Itm).Range("B3").CurrentRegion
 Ro = Rg.Rows.Count
  If Ro > 1 Then
    With Sheets(Itm).Range("A4").CurrentRegion
      .Cells(2, 1).Resize(Ro - 1).Value = _
       Evaluate("Row(1:" & Ro - 1 & ")")
      .Borders.LineStyle = 1
      .InsertIndent 1
      .Font.Size = 14
      .Font.Bold = True
      .Interior.ColorIndex = 35
      .Rows(1).Interior.ColorIndex = 6
    End With
  End If
 Next
 Tousi3.AutoFilterMode = False
 Tousi3.Select
 With Application
 .ScreenUpdating = True
 .Calculation = xlCalculationAutomatic
 End With

End Sub

الملف مرفق

 

marwa41.xlsm

[marwa41]

بسم الله ما شاء الله 

ربنا يبارك فى حضرتك ويجعل علمك فى ميزان حسناتك 

يوجد ملحوظة صغير 

المعادلات لا تعمل فى الشيت الرئيسى 

[سليم حاصبيا]

تم معالجة الأمر

لا لزوم لادراج معادلات الا في العامود E ابتداء من الخلية E7

تم ادراج تواريخ عشوائية للتأكد من عمل الماكرو بشكل صحيح

marwa_New_1.xlsm

[marwa41]

اعجز عن الشكر لك لكن عندما يجزيك الله خيرا افضل من الدنيا وما فيها

لكن لابد من وجود عملية الضرب الكمية فى السعر لاعطائى القيمة 

 

[خيماوي كووول]

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

تفضل اخوي العزيز ..

ااجمالى كميات السولار.xlsm

[سليم حاصبيا]

في العامود K    لا يتعير شيء
المعادلات تعمل في الصفحة الرئيسية  و تنقل الى باقي البشيتات قيمتها فقط     
 وذلك لتقليل حجم الملف من حيث عدد المعادلات فيه (اذ يمكن ان يتخيل الانسان 20 صفحة زيادة (حسب عدد العملاء)   و في كل واحدة
  اكثر من 50 معادلة) فلماذا لا نجعل  الاكسل يرتاح من حسابها

[marwa41]

المعادلات فى الشيت الرئيسى فعلا لا تعمل ضرب الكمية فى السعر بمعادلة if

 

[سليم حاصبيا]

استعمل هذه المعادلة بدل التي وضعتها لتفادي الخطأ في حال تم كتابة نص او اي شيء غير الارقام في العامودين I  و  J

الملف مرفق من جديد

marwa_New_2.xlsm

[marwa41]

تسلم يا عبقرى