استدعاء بيانات صفحة الى صفحه اخرى لها نفس الرؤوس .. بشرط

[ناصر سعيد]

بسم الله الرحمن الرحيم

احبابنا في الله

هذا كود خاص باستدعاء بيانات صفحه كامله الى صفحه اخرى مثلها في رؤوس العناوين ولكن بشرط - ( تصفيه بيانات ) -

وهو خاص للمحترم الذي اكن له كل تقدير واحترام

الاستاذ زيزو العجوز

 

Sub Trans_Data()
'الكود خاص بالمحترم زيزو العجوز
'يحفظه الله
'تم هذا الكود في 15/11/2017
'الهدف من الكود هو استدعاء صفحة كامله بشرط
'================

'الاعلان عن اسماء الشيتات'
Dim Main As Worksheet, sh As Worksheet

'  الاعلان عن المصفوفتين
Dim Arr As Variant, Temp As Variant

'(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p  ) وعداد المصفوفة الثانية
Dim i As Long, j As Long, p As Long

' الاعلان عن المتغير الذى سوف يتم العمل عليه
Dim dep As String

Set Main = Sheets("المصدر")
Set sh = Sheets("الهدف")
'=======
'  محو البانات القديمة
sh.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

'    معيار الاختيار
dep = sh.Range("C1").Value

 '     المصفوفة المصدر
Arr = Main.Range("A7:CX" & 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, 101) Like "*" & dep & "*" Then
'If Arr(i, 101) = 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("A7").Resize(p, UBound(Temp, 2)).Value = Temp

End Sub

 

==================

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

***************

ويوجد بالملف ايضا

كود فلتره للمحترم الاستاذ الخلوق سليم حاصبيا

ولكن لم استطع تطويع الكود في الملف

فادعو الله ان يتم تطويع كوده للافاده

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

Option Explicit

Sub Filter_Me()

Sheets("الهدف").Range("a8").CurrentRegion.ClearContents
Sheets("المصدر").Range("a8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("الهدف").Range("m1:n2"), copytorange:=Sheets("الهدف").Range("a8")
End Sub

 

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

[ناصر سعيد]

الاستاذ زيزو

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

من فضلك

اريد وضع هذه الاسطر البرمجيه في الكود

اين اماكن وضعهم ؟

   'سطر لمسح التسطير
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0
   
   'سطر للتسطير
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1

 

====

مع تضبيطهم  كرما منك

[ناصر سعيد]

او اي فكره للتسطير تعجبك

[ناصر سعيد]

او اي فكره للتسطير تعجبك