اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

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

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

تجميع salim.xlsb

رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

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

  • Like 2
رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

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

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

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

ws.Cells(m, 5) = .Name

 

  • Like 1
رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

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

 

رابط هذا التعليق
شارك

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

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

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

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

 

data_val.png

رابط هذا التعليق
شارك

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

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

 

pic_3.png

رابط هذا التعليق
شارك

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

If lra < 10 Then lra = 10

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

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

Extra_Filter _ziad.xlsm

  • Like 2
رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

لا أعرف السبب

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

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

 

Ziad.png

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information