طلب تعديل في كود الاستاذ سليم حاصيبا

[زياد عبد الجليل]

السلاام عليكم اخوتي الافاضل عيدكم مبارك كل عام وانتم بخير

لدي طلب بسيط يتمثل في تعديل كود لملف الاستاذ سليم يقوم بتجميع البيانات في صفحة محددة المطلوب بدقة موجود في الملف

تجميع salim.xlsb

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

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

 

MY_Filter.xlsm

 

[زياد عبد الجليل]

شكرا لك استاذ سليم لكن كنت اريد فرز بدلالة المهام و ليس القسم اي اكتب المهام ويتم فرزهم اي كتابة نص و ليس عدد ..شكرا لمرورك الطيب

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

Sub filter_and_copy()
Dim my_sheet As Worksheet
Dim ws As Worksheet
Dim my_rg As Range
Dim lra%, k%, m%, v%, X%
Dim arr(), S_rg As Range
Application.ScreenUpdating = False
m = 2
arr = Array(1, 2, 4, 5)

k = Sheets.Count
Set ws = Sheets("المطلوب")
lra = ws.Cells(Rows.Count, 1).End(3).Row
If lra < 2 Then lra = 2
ws.Range("A2:E" & lra).Clear

  my_creteria = ws.Range("H1")
 For i = 1 To k
  If Sheets(i).Name = ws.Name Then GoTo Next_i
  With Sheets(i)
   Set S_rg = .Range("D:D").Find(my_creteria, lookat:=1)
   If S_rg Is Nothing Then GoTo Next_i
   If .AutoFilterMode Then
   .Range("A1:E1").AutoFilter
   End If
 Set my_rg = .Range("A2").CurrentRegion
 X = .Cells(Rows.Count, 1).End(3).Row
  '=====================================
  my_rg.AutoFilter Field:=4, _
  Criteria1:="=" & my_creteria & ""

  For v = LBound(arr) To UBound(arr)
   .Range("A2:E" & X).Columns(arr(v)).SpecialCells(2).Copy
    ws.Cells(m, v + 1).PasteSpecial (12)
  Next
  Application.CutCopyMode = False
       ws.Cells(m, 5) = .Name
     m = ws.Cells(Rows.Count, 2).End(3).Row + 2
     If .AutoFilterMode Then
      .Range("A1:E1").AutoFilter
     End If

  '====================================
  End With
Next_i:
  Next i
 v = ws.Cells(Rows.Count, 1).End(3).Row
 If v < 2 Then GoTo End_Me
  With ws.Range("A1:E" & v).SpecialCells(2)
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 14
    .Interior.ColorIndex = 35
    .InsertIndent 1
    With .Cells(1, 1).Resize(, 4)
    .Interior.ColorIndex = 6
    .HorizontalAlignment = 3
    End With
  End With
End_Me:
  Application.ScreenUpdating = True
End Sub

تم التعديل على الملف كما تريد

1-المهام مدرجة في قائمة منسدلة في الخلية   H1  غير مكررة (توفيراً للوقت في الكتابة من جهة وتجنياً
                                 للأخطاء الكتابية من جهة أخرى المسافات الزائدة او النافصة او اخطاء املائية)

2- اذا لم تظهر القائمة المنسدلة غادر الصفحة وعد اليها مجدداً

3- في حال كانت الخلية  H1 فارغة الماكرو يقوم بجلب كل البيانات

4-الملف مرفق

Extra_Filter.xlsm

[زياد عبد الجليل]

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

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

تضيف رقمه على الـــ  Array

الـــ  Array يحتوي على الأعمدة الواجب نقلها بالترتيب

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

ws.Cells(m, 5) = .Name

 

[زياد عبد الجليل]

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

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

الكود يظهر كل البينات اذا كانت الخلية H1 فارغة

لا اعرف ما المشكلة عندك

[زياد عبد الجليل]

مثلا لو اردت ان يجمع لي البيانات و يعرضها في الصف4 و في الصف الثالث اضع عنوان عندما تكون القيمة المبحوث عنه غير موجودة يقون الكود بحذف العنوان وان اريد ان يبقى العنوان لا يحذف

 

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

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

لكتابة اي معادلة على الشيت يجب الابتعاد عن الجدول الأخضر 

لان الأعمدة من A الى E تحت سيطرة الماكرو  وهو يقوم بحذفها ليضع مكانها البيانات الجديدة

دع معادلاتك تكون في العامود G  و ما بعده  في اي صف تريد

 

[زياد عبد الجليل]

استاذ سليم شكرا لتفاعلك معي اليك المطلوب بذقة

Extra_Filter.xlsm

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

من قال لك ان بيدأ جدولك من الصف رقم 10

الماكرو مصمم ان يبدأ عملة من الصف رقم2  لذلك هو يقوم بمسح كل شيي ابتداء من الصف رقم 2 ونزولاُ ومن ضمنهم الصف 10 

 

[زياد عبد الجليل]

استاذ سليم شكرا لك على المساعدة لقد وجدت الحل

If lra < 10 Then lra = 10

غيرت الصف هنا بارك الله فيك على ارشادي للطريقة

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

بهذه الطريقة سوف تضيع صف العناوين

تم التعديل على الملف الاساسي لتبدأ البيانات من االصف 11

مع الاحتفاظ بالصف العاشر كعنوان

Extra_Filter _ziad.xlsm

[زياد عبد الجليل]

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

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

لا شرط لذلك

الفلتر يفعلها وحده

[زياد عبد الجليل]

عندما اترك الخلية فارغة و اضغط زر الفلترة في ملفي الخاص تضهر رسالة خطأ

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

لا أعرف السبب

هل يفعل هذا الشيء في الملف الدي رفعته لك؟؟

اذا كنت لا تريد شيئاً في حال كانت الخلية فارغة   ضع هذا الشرط في الكود في المكان المناسب (حسب الصورة)

 

[زياد عبد الجليل]

الملف الذي رفعته لي يعمل بشكل ممتازالمشكلة في ملفي