فلترة البيانات مع وجود دمج الخلايا للمحترم استاذ سليم حاصبيا

[ناصر سعيد]

من روائع اعمال المحترم استاذ سليم حاصبيا

في فلتره البيانات الى اي عدد من الشروط (المعايير )

جزاه الله عنا كل خير وبارك فيه يارب

Option Explicit
Sub transfer_data()
'هذا الكود للمحترم سليم حاصبيا
'الهدف من الكود هو فلتره البيانات
'وترحيلها الى صفحات
'تم هذا الكود في 6/12/2007
'====================
Dim My_Rg As Range
Dim S_sh As Worksheet, My_Sheet As Worksheet
Dim i As Byte

'======
    'عدد صفحات الملف كاملا او اكثر
Dim arr(1 To 44)
'======

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
'======
    'عدد الصفحات المطلوب الترحيل اليها+ صفحة المصدر
For i = 2 To 7
'======

 arr(i - 1) = Sheets(i).Name
 Next
 
 'اسم صفحه المصدر
Set S_sh = Sheets("المصدر")

'بدايه النطاق المطلوب فلترته
Set My_Rg = S_sh.Range("A14").CurrentRegion

If S_sh.AutoFilterMode = False Then
My_Rg.AutoFilter
End If

'======
    'عدد الصفحات المطلوب الترحيل اليها
 For i = 1 To 6
'======
 
  Set My_Sheet = Sheets(arr(i))
  
  'نطاق المسح في صفحات الهدف
  My_Sheet.Range("B4:F500").Clear
  
  'رقم عمود الفلتره
  My_Rg.AutoFilter field:=4, Criteria1:=arr(i)
  
  'بدايه خليه النسخ في صفحات الهدف
My_Rg.SpecialCells(12).Copy My_Sheet.Range("B4")
My_Rg.AutoFilter
Next
  With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

'كي لا تبقى شيء في الذاكرة يثقلها 
     Erase arr
Set S_sh = Nothing: Set My_Sheet = Nothing: Set My_Rg = Nothing: i = 0
End Sub

 

======

الفكره بالرغم من بساطتها رائعه ...

ترك صفين تحت الرؤوس المدمجه ...

الصف الاول الذي تركناه ... يكون فاضي

والصف اللي تحته يكون فيه اسماء العناوين بدون دمج 

حفظك الله ورعاك يا استاذ سليم

========

الفلتره للمحترم سليم حاصبيا1.rar

[ناصر سعيد]

اسم الصفحه سيكون هو الشرط

[ناصر سعيد]

لرقم 12 هو اختصار للعبارة "xlCellTypeVisible" 

جزاك الله خيرا استاذ سليم