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

[marwa41]

السلام عليكم ممكن من اهل العلم المساعدة فى هذا العمل 

عند تغير فى شيت الصندوق يحدث انشاء صفحة جديدة على اساس الكود المحاسبى وترحيل بدون حذف فى شيت الاكسيل وعند اضافى بيانات جديدة فى شيت الاكسيل تبقى جميع البيانات كما هى فى شيت الاكسيل وترحل البيانات الى الشيتات الاخرى وعدم وجود بها تكرار 

الصندوق2020.xlsm

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

تغيير اسم الصفحة الاولى الى  Main  لسهولة نسخ الكود ولصقه

الكود

Option Explicit
Sub Salim_code()
Application.ScreenUpdating = False
  Dim Filt_Rg    As Range
  Dim M          As Worksheet
  Dim Sh         As Worksheet
  Dim i%

  Set M = Sheets("Main")
  Set Filt_Rg = M.Range("B3").CurrentRegion

If M.AutoFilterMode Then
 Filt_Rg.AutoFilter
End If
i = 4
Do Until M.Range("k" & i) = vbNullString
 If Not Application.Evaluate("ISREF('" & M.Range("k" & i) & "'!A1)") Then
   Sheets.Add(, M).Name = M.Range("k" & i)
 End If
 i = i + 1
 Loop
For Each Sh In Sheets
  If Sh.Name <> M.Name Then
    Sh.Range("B3").CurrentRegion.Clear
    Filt_Rg.AutoFilter 10, Sh.Name
    Filt_Rg.SpecialCells(12).Copy Sh.Range("B3")
    Sh.Range("B3").CurrentRegion.Columns.AutoFit
  End If
Next
M.Select
If M.AutoFilterMode Then
 Filt_Rg.AutoFilter
End If
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Sandouk_2020.xlsm

[marwa41]

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

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

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

لكن ممكن طلب 

عمل فيديو شرح هذا الكود الممتاز

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

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

لذا اقترح :

1-مسح كل الصفحات ما عدا الصفحة Main 

2-بعد ذلك يمكن تتبع خطوات الماكرو خطوة خطوة لمعرفة كيفية عمله

[عبدالفتاح في بي اكسيل]

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