اذهب الي المحتوي
أوفيسنا

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

قام بنشر

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

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

تجميع 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

قام بنشر

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

قام بنشر

لا أعرف السبب

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

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

 

Ziad.png

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

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

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

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

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

Important Information