ترحيل وتصفية بيانات من ورقة 1 الى ورقة 2

[ابو غريب]

ارجو من حضراتكم داله او كود يتم ترحيل البيانات من ورقة 1 الى ورقة 2 حسب الادارة بقائمة منسدله

المصنف1.rar

[ابراهيم الحداد]

السلام عليكم ورحمة الله

تفضل اخى الكريم

اختر الادارة من الخلية "L1" بالورقة الثانية

 

المصنف1.rar

[ناصر سعيد]

الاستاذ المحترم زيزو العجوز

يحفظك الله ويرعاك

ارجو وضع شرح لاكوادك دائما لانها مراجع يستفيد منها الكثيرون ونتعلم منها

====

اين الجزئيه التي تجعلنا نغير في بدايه وضع النتائج في صفحة الهدف

وكذلك في صفحه المصدر

بارك الله فيك

=======

Sub TransData()
Dim Main As Worksheet, sh As Worksheet
Dim Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long
Dim dep As String
Set Main = Sheets("المصدر")
Set sh = Sheets("الهدف")
'=======
sh.Range("A2:J" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents
dep = sh.Range("L1").Value
Arr = Main.Range("A2:J" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 4) = dep Then
p = p + 1
For j = 1 To UBound(Arr, 2)
Temp(p, j) = Arr(i, j)
Next
End If
Next
If p > 0 Then sh.Range("A2").Resize(p, UBound(Temp, 2)).Value = Temp
End Sub

 

[ابراهيم الحداد]

السلام عليكم ورحمة الله
اخى الكريم / ناصر اليك شرح الكود كما ظلبت

Sub TransData()
Dim Main As Worksheet, sh As Worksheet الاعلان عن اسماء الشيتات
Dim Arr As Variant, Temp As Variant '  الاعلان عن المصفوفتين
Dim i As Long, j As Long, p As Long  '(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p  ) وعداد المصفوفة الثانية
Dim dep As String '   (جنوب,شمال,غرب,شرق) الاعلان عن المتغير الذى سوف يتم العمل عليه  
Set Main = Sheets("المصدر")
Set sh = Sheets("الهدف")
'=======
'  محو البانات القديمة
sh.Range("A2:J" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents
'    معيار الاختيار  
dep = sh.Range("L1").Value
 '     المصفوفة المصدر
Arr = Main.Range("A2:J" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value
'     ابعاد المصفوفة الهدف 
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
 '     طول المصفوفة المصدر
For i = 1 To UBound(Arr, 1)
 '    شرط تعبئة المصفوفة الهدف
If Arr(i, 4) = dep Then
 '    العداد لتحديد طول المصفوفة الهدف
p = p + 1
 '     عرض المصفوفة الهدف
For j = 1 To UBound(Arr, 2)
'  تعبئة المصفوفة الهدف من المصفوفة المصدر حسب الشرط
Temp(p, j) = Arr(i, j)
Next
End If
Next
 '  واخيرا عرض البيانات المطلوبة
If p > 0 Then sh.Range("A2").Resize(p, UBound(Temp, 2)).Value = Temp
End Sub

 

[ابو غريب]

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

المصنف1.rar

[ناصر سعيد]

الاستاذ المحترم زيزو العجوز

يحفظك الله

عند تطويع كودك الرائع على هذا الملف لم يعمل .. لماذا .. وارجو تطويعه

 

استدعاء صفحة بشرط.rar

الاخ ابو غريب

هذا طلبك

 

استدعاء صفحة كامله .. بشرط.rar

[ابو غريب]

شكرا لمرور حضرتك الكريم ياخى الفاضل ناصر كنت اريد ان ارحل واصفى البيانات من الصفحة 1 الى الصفحة 2 حسب الادارة وبعدها اصفى وارحل الى الصفحة 3 على حسب القاعة بعدها اقوم بالطباعة

المصنف1.rar

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

بعد اذن اخي زيزو هذا الكود من سطرين فقط

Option Explicit

Sub Filter_Me()

Sheets("ورقة2").Range("a1").CurrentRegion.ClearContents
Sheets("ورقة1").Range("a1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("ورقة2").Range("m1:n2"), copytorange:=Sheets("ورقة2").Range("a1")
End Sub

الملف مرفق

 

المصنف1 Salim.rar

[ابراهيم الحداد]

السلام عليكم ورحمة الله
اخى الكريم / ناصر
استبدل هذا السطر فى الكود

If Arr(i, 101) = dep  Then

بهذا السطر

If Arr(i, 101) Like "*" & dep & "*" Then

 

[ابراهيم الحداد]

السلام عليكم ورحمة الله

عفوا اخى الكريم / ناصر

فالرد السابق سيجمع بين اسماء الناجحين من البنين والبنات

وبمراجعة الخطأ لابد من اعادة نسخ كلمة ناجح من العمود 101 فى الورقة الاولى

ولصقها فى الخلية "G1" بالورقة الثانية و كذلك فى كل المعايير التى لا تعمل معك

            والله ولى التوفيق

[ناصر سعيد]

وعليكم السلام ورحمة الله وبركاته

ربنا يحفظك ويصونك يارب

تم تعديل نوفمبر 15, 2017 بواسطه ناصر سعيد

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

15 ساعات مضت, ناصر سعيد said:

الاستاذ المحترم زيزو العجوز

يحفظك الله

عند تطويع كودك الرائع على هذا الملف لم يعمل .. لماذا .. وارجو تطويعه

 

استدعاء صفحة بشرط.rar

الاخ ابو غريب

هذا طلبك

 

استدعاء صفحة كامله .. بشرط.rar

جرب هذا الكود (اعتقد انه اسرع و لايحتاج الى حلفات تكرارية)

Sub filter_for_ME()
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
    End With
Dim S_sh As Worksheet: Set S_sh = Sheets("المصدر")
Dim T_sh As Worksheet: Set T_sh = Sheets("الهدف")
Dim My_Table As Range: Set My_Table = S_sh.Range("A1").CurrentRegion

T_sh.Range("a1").CurrentRegion.ClearContents
T_sh.Range("s2").Formula = "=المصدر!$H2=الهدف!$L$1"

My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("s1:s2"), _
CopyToRange:=T_sh.Range("A1")
T_sh.Range("s2").ClearContents
    With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
    End With
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$L$1" Or Target.Count > 1 Then GoTo 1
Application.EnableEvents = False
filter_for_ME
1:
Application.EnableEvents = True
End Sub

الملف مرفق بصيغة 2003 كي يستفيد منه العدد الاكبر من الاعضاء

 

استدعاء صفحة كامله .. بشرط salim.rar

[ناصر سعيد]

المحترم سليم حاصبيا

السلام عليكم ورحمة الله

لم استطع فهم كودك لوجود اسماء خلايا

اجدها فارغه مثل خليه S1   و S2

موجود ايضا a1 ابتداء المسح بالرغم من انها راس عنوان

 ارجو شرح الكود واضافته في ملفي هذا  .. يحفظك الله

 

استدعاء صفحة بشرط.rar

[ابو غريب]

شكرا للسادة الخبراء جزاكم اللله خير وجعله الله فى ميزان حسناتكم

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

3 ساعات مضت, ناصر سعيد said:

المحترم سليم حاصبيا

السلام عليكم ورحمة الله

لم استطع فهم كودك لوجود اسماء خلايا

اجدها فارغه مثل خليه S1   و S2

موجود ايضا a1 ابتداء المسح بالرغم من انها راس عنوان

 ارجو شرح الكود واضافته في ملفي هذا  .. يحفظك الله

 

استدعاء صفحة بشرط.rar

كي يعمل الكود بشكل ممتاز يجب ازالة اشد اعداء الـــ VBA اعني الخلايا المدمجة

[ناصر سعيد]

7 ساعات مضت, ناصر سعيد said:

المحترم سليم حاصبيا

السلام عليكم ورحمة الله

لم استطع فهم كودك لوجود اسماء خلايا

اجدها فارغه مثل خليه S1   و S2

موجود ايضا a1 ابتداء المسح بالرغم من انها راس عنوان

 ارجو شرح الكود  من فضلك وخاصه هذه الخلايا الموجوده بالكود وفارغه في صفحه الاكسيل

 

 

 

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

الكود يقوم بالتصفية عن طريق Advanced filter

يجب ان تكون الصفحة T_sh محددة (اي الصفحة "الهدف")

1-ادخل على صفحة الكود  و قم بتعطيل الكود (حدث الصفحة) عن طريق وضع فاصلة عليا  عند كل سطر من اسطره

ليصيح الكود بهذا الشكل

Option Explicit

Sub filter_for_ME()
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
    End With
Dim S_sh As Worksheet: Set S_sh = Sheets("المصدر")
Dim T_sh As Worksheet: Set T_sh = Sheets("الهدف")
Dim My_Table As Range: Set My_Table = S_sh.Range("A1").CurrentRegion

T_sh.Range("a1").CurrentRegion.ClearContents
T_sh.Range("s2").Formula = "=المصدر!$H2=الهدف!$L$1"

My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("s1:s2"), _
CopyToRange:=T_sh.Range("A1")
T_sh.Range("s2").ClearContents
    With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
    End With
End Sub


'Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Address <> "$L$1" Or Target.Count > 1 Then GoTo 1
'Application.EnableEvents = False
'filter_for_ME
'1:
'Application.EnableEvents = True
'End Sub

2-ضع المؤشر داخل الكود filter_for_ME

3-بواسطة المفتاح F8 نفذ الكود خطوة خطوة و لا حظ ماذا يجري على الصفحة و ستفهم الكود يسرعة

4- بعد دراسة الكود ازل الفواصل العليا ليعود كل شيء الى طبيعته

[ناصر سعيد]

الاستاذ سليم

يحفظك الله ... وبعد

الكود يقوم بالتصفية عن طريق Advanced filter

يجب ان تكون الصفحة T_sh محددة (اي الصفحة "الهدف")

1-ادخل على صفحة الكود  و قم بتعطيل الكود (حدث الصفحة) عن طريق وضع فاصلة عليا  عند كل سطر من اسطره

2-ضع المؤشر داخل الكود filter_for_ME

3-بواسطة المفتاح F8 نفذ الكود خطوة خطوة و لا حظ ماذا يجري على الصفحة و ستفهم الكود يسرعة

4- بعد دراسة الكود ازل الفواصل العليا ليعود كل شيء الى طبيعته

( اقتباس )

  بعد عمل ذلك تظهر الاسطر البرمجيه كل سطر ملون باللون الاصفر ومش عارف اعمل ايه تان

او افهم الكود ازاي من اللون الاصفر ...

 

 

 

 

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

30 دقائق مضت, ناصر سعيد said:

الاستاذ سليم

يحفظك الله ... وبعد

الكود يقوم بالتصفية عن طريق Advanced filter

يجب ان تكون الصفحة T_sh محددة (اي الصفحة "الهدف")

1-ادخل على صفحة الكود  و قم بتعطيل الكود (حدث الصفحة) عن طريق وضع فاصلة عليا  عند كل سطر من اسطره

2-ضع المؤشر داخل الكود filter_for_ME

3-بواسطة المفتاح F8 نفذ الكود خطوة خطوة و لا حظ ماذا يجري على الصفحة و ستفهم الكود يسرعة

4- بعد دراسة الكود ازل الفواصل العليا ليعود كل شيء الى طبيعته

( اقتباس )

  بعد عمل ذلك تظهر الاسطر البرمجيه كل سطر ملون باللون الاصفر ومش عارف اعمل ايه تان

او افهم الكود ازاي من اللون الاصفر ...

 

 

 

 

هذا هو المطلوب بالضبط

قم يتصغير شاشة الكود و شاشة الاكسل الى النصف تقريباً(ضعهما جانب بعضهم البعض)

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

لاجظ ما يجري على صفحة الاكسل بعد كل كبسة F8  وخاصة لاحظ المعادلة(المؤقتة) التي سوف تظهر قي الخلية s2 عند السطر

"المصدر!$H2=الهدف!"= T_sh.Range("s2").Formula 

هذه المعادلة يقوم على اساسها الفلتر

بعد تنفيذ الفلتر تمسح هذه المعادلة لانه لا لزوم لها بعد بواسطة هذا السطر

T_sh.Range("s2").ClearContents

يمكنك اعادة المحاولة من البداية قدر ما تريد من المرات مع تغيير قيمة الخلية L1 بواسطة f8

[ناصر سعيد]

ان شاء الله هانوصل

===

قم يتصغير شاشة الكود و شاشة الاكسل الى النصف تقريباً (ضعهما جانب بعضهم البعض) ..

( اقتباس )

وكيف يتم التصغير  ؟

جزاك الله خيرا

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

منذ ساعه, ناصر سعيد said:

ان شاء الله هانوصل

===

قم يتصغير شاشة الكود و شاشة الاكسل الى النصف تقريباً (ضعهما جانب بعضهم البعض) ..

( اقتباس )

وكيف يتم التصغير  ؟

جزاك الله خيرا

انظر الى هذه الصورة

صورة.rar