الترحيل حسب اكثر من شرط لاسماء اوراق العمل المطابقة للشرط

[فهدبن]

مساء الخير

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

ويجزي الجميع خير الجزاء

قمت بتطبيق شرح للترحيل للمبدع عبدالله المجرب

حسب اسم الصفحة طبقاً لعمود معين

ولكني اريد ايضاً الترحيل طبقاً لعمود ثاني

فلدي عمود جهة وعمود موقع

واريد الترحيل حسب كلا العمودين

مع العلم اني جربت جعل متغيرين ولم ينجح العمل

مع ملاحظة 

لصق البيانات لصق خاص او لصق القيم بدون  المعادلات 

2متابعة .rar

[رجب جاويش]

السلام عليكم

جرب أخى هذا الكود

يقوم بالترحيل مع انشاء الصفحات مع نسخ التنسيقات

لعله يكون كما يريد

Sub ragab()
Dim cl As Range, sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If Not sh.Name = "البيانات" Then
sh.Range("A1:J1000").ClearContents
End If
Next
LR1 = Cells(Rows.Count, 6).End(xlUp).Row
LR2 = Cells(Rows.Count, 8).End(xlUp).Row
Set Rng1 = Range("F2:F" & LR1)
Set Rng2 = Range("H2:H" & LR2)
Set Rng = Union(Rng1, Rng2)
For Each cl In Rng
x = Trim(cl.Value)
On Error Resume Next
If Worksheets(x) Is Nothing Then
Sheets.Add.Name = x
Sheets(x).Move After:=Sheets(Sheets.Count)
End If
Sheets("البيانات").Range("A1:J1").Copy
Sheets(x).Range("A1").PasteSpecial xlPasteValues
Sheets(x).Range("A1").PasteSpecial xlPasteFormats
Sheets("البيانات").Cells(cl.Row, 1).Resize(1, 10).Copy
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
Next
MsgBox "تم الترحيل بنجاح الى صفحات منفصلة"
Sheets("البيانات").Select
Application.ScreenUpdating = False
End Sub

 

2متابعة .rar

 

تم تعديل يناير 27, 2016 بواسطه رجب جاويش

[فهدبن]

شكرا لك اخي  رجب

الكود قام بعمل المطلوب تماماً

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

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

[رجب جاويش]

أخى الفاضل

تم فعلا التجهيز لترحيل 1000 صف عن طريق مسح 1000 صف من الصفحات المرحل اليها لاستقبال البيانات المرحلة

ويمكن زيادة العدد عن زيادة العدد فى الصف التالى من الكود الى اى عدد تريده

sh.Range("A1:J1000").ClearContents

أما مسح البيانات المرحلة فيحتاج بعض التعديلات فى الكود

فاذا كنت فى احتياج لمسح البيانات بعد الترحيل أخبرنى

[مختار حسين محمود]

أستاذى الفاضل رجب

كود رائع بارك الله فيك

ملحوظة صغيرة و ليس تعديلا  : 

كما قال أخونا وأستاذنا ياسر خليل لا تنسى الاعلان عن كل المتغيرات فى أكوادك

اجعل السطر التالى :     Option Explicit  على رأس أكوادك فهو لن يتركك الا اذا أعلنت عن كل المتغيرات و كفيل  بتذكيرك بذلك

تحياتى

 

تم تعديل يناير 28, 2016 بواسطه مختار حسين محمود

[رجب جاويش]

أخى الفاضل / مختار

جزاك الله خيرا على هذا المرور العطر

ويظهر ان الحل الوحيد لنسيان تعريف المتغيرات هو  Option Explicit

أصبت وأحسنت

تقبل تحياتى