البحث في الموقع
Showing results for tags '`'.
تم العثور علي 1 نتيجه
-
من روائع اعمال المحترم استاذ سليم حاصبيا في فلتره البيانات الى اي عدد من الشروط (المعايير ) جزاه الله عنا كل خير وبارك فيه يارب 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
