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

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

Recommended Posts

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

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

تجميع 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 اعضاء متواجدين الان

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

×
×
  • اضف...