ترحيل من شيت ١ الى شيت ٢ ب ثلاثة شروط

[أبو قاسم]

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

 

محتاج ترحيل من شيت ١ الى شيت٢ بثلاثة شروط هي التاريخ ... والفترة ..... والوظيفة يوجد مثال على شيت ٢ 

المصنف٢.xlsx

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

1- الصف الثالث من الورقتين(Row 3) يجب ان يكون فارغاً تماماً (لفصل الجدول عن باقي البيانات و بالتالي يتعرّف الاكسل على النطاق الواجب العمل عليه)

2- لا ضرورة للقوائم المنسدلة في ورقة 2

3- تجدد المطلوب من الورقة1 (الخلايا J2 و K2  و L2) ثم الضغط على الزر Run فينتقل المطلوب الى الورقة الثانية

4-في حال كانت اجد الخلايا ( J2 و K2  و L2) او أكثر فارغة (نتكلّم عن الورقة 1)  تتم الفلترة على كل البيانات التابعة للخلية (الخلابا الفارعة)

       مثلا اذا كانت الخلية L2 فارغة تتم الفلترة على كل الفئات (أولى /ثانية / ثالثة)

مع الاخذ بالاعتبار الخلايا (J2 و K2)

 5-  الماكرو

Option Explicit

Sub Copy_dat()
    Dim Source_Sheet As Worksheet, Target_Sheet As Worksheet
    Dim Source_Sheet_rg As Range, Target_Sheet_rg As Range
    Dim Criterea_rg As Range
    Dim Where_rg As Range
    Dim How_many%

  Set Source_Sheet = Sheets("ورقة1"): Set Target_Sheet = Sheets("ورقة2")
  Set Source_Sheet_rg = Source_Sheet.Range("A4").CurrentRegion
  Set Target_Sheet_rg = Target_Sheet.Range("A4").CurrentRegion
  Set Criterea_rg = Source_Sheet.Range("J1:L2")
  Set Where_rg = Target_Sheet.Range("A4:J4")
 How_many = Source_Sheet.Cells(Rows.Count, 3).End(3).Row

  Target_Sheet.Range("A5:J" & How_many).Clear

Source_Sheet_rg.AdvancedFilter 2, Criterea_rg, Where_rg
    Set Where_rg = Target_Sheet.Range("A4").CurrentRegion
    How_many = Target_Sheet_rg.Rows.Count
     If How_many > 1 Then
      With Where_rg.Offset(1).Resize(How_many - 1)
      .Borders.LineStyle = 1: .InsertIndent 1
      .Font.Size = 14: .Font.Bold = True
      .Interior.ColorIndex = 35
      End With
     End If
End Sub

الملف مرفق

 

 

Advanced_filter.xlsm

[أبو قاسم]

جزاك الله خير