ترحيل تلقائى

[nagy alnagar]

السلام عليكم

محتاج داله لترحيل البيانات من الشيت الرئيسى الى شيتات (دمياط و الفيوم و عملاء اخرون ) حسب العميل و العنوان

مع بقاء البيانات في الشيت الرئيسى

جزيتم خيرا

1.xlsx

[Ali Mohamed Ali]

أهلا وسهلا بك فى منتدانا الكريم

تفضل اخى الكريم لعله المطلوب

 

1.xlsm

[nagy alnagar]

جزاك الله كل خير أخي الفاضل الاستاذ / ali mohamed ali

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

انا كنت عاوزها بداله if  لو امكن

[Ali Mohamed Ali]

على فكرة الكود اسرع وادق من المعادلات

[Ali Mohamed Ali]

تفضل هذا ما طلبت بالمعادلات

 

1.xlsm

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

عد اذن اخي علي 

هذا الكود (سريع جداُ لانه يستعمل adanvced filter)

Option Explicit
Sub filter_for_ME()
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
    End With
Dim i%, k%: k = Sheets.Count
Dim S_sh As Worksheet: Set S_sh = Sheets("سحب مباشر")
Dim T_sh As Worksheet
Dim My_Table As Range: Set My_Table = S_sh.Range("b3").CurrentRegion
  For i = 2 To k
  Set T_sh = Sheets(i)
    With T_sh
        .Range("b3").CurrentRegion.Clear
        .Range("q1") = "العنوان"
        .Range("q2") = T_sh.Name
    End With
My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("Q1:q2"), _
CopyToRange:=T_sh.Range("b3")
T_sh.Range("q1:q2").ClearContents
Next
    With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
   End With

End Sub

الملف مرفق

 

salim_Adv_Fllter.xlsm

[nagy alnagar]

جزاك الله كل خير أخي الفاضل الاستاذ / ali mohamed ali

ممكن رقم حضرتك

الاستاذ  سليم حاصبيا  بارك الله فيك  و شكرا على اهتمامك

[muhammad gida]

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

 

[علي عبد المنعم]

استاذ سليم // كود اكثر من رائع بارك الله فيك // واطمع في المزيد بشرح الكود لكي يتم الاستفادة والتعلم منه في التطبيق على ملفات اخرى

 

تم تعديل أبريل 30, 2018 بواسطه علي عبد المنعم

[علي عبد المنعم]

 

هل من الممكن جعل الكود يعمل تلقائيا بدون الضغط على زر ترحيل 

تم تعديل أبريل 30, 2018 بواسطه علي عبد المنعم