ترحيل من الرئيسية الى شيتات اخرى

[Muner]

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

تحية

بعد التحية اهنئكم بالعام الهجري الجديد نسأل الله ان يجعله عام خير .

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

والتوضيح داخل الملف المرفق 

 

حساب المدرسة.xls

[أبوأحـمـد]

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

تفضل

 

حساب المدرسة.xlsm

[Muner]

شكرا جزيلا أخي أبو احمد وجعله الله في ميزان حسناتك ، هو فعلا المطلوب بس ياليت تترجم لي الكود لان بعض فقراته لم افهمها لقلة خبرتي بالاكواد .وشكرا لك مرة ثانية 

[أبوأحـمـد]

33 دقائق مضت, Muner said:

ياليت تترجم لي الكود لان بعض فقراته لم افهمها لقلة خبرتي بالاكواد

Sub Export()

'تعريف المتغيرات
Dim WshtNames As Variant
Dim WshtNameCrnt As Variant
Dim Rang1 As Range
Dim wk As Worksheet
Dim nsh As String
Dim wk_Row, wk1_Row, r As Integer

'تحميل متغير الورقة الرئيسية
 Set wk = Worksheets("الرئيسية")

'تحميل متغير صفوف البيانات في الورقة الرئيسية
wk_Row = 10000
    
'تحميل متغير نطاق البيانات في الورقة الرئيسية
Set Rang1 = wk.Range("C6:C" & wk_Row)
  
'تحميل متغير اورق المراد الإرسال لها
WshtNames = (Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع"))

'مسح البيانات السابقة
  For Each WshtNameCrnt In WshtNames
        With Worksheets(WshtNameCrnt)
        wk1_Row = .Range("B10000").End(xlUp).Row
        .Range("B3:c" & wk1_Row + 1) = ""
        End With
   Next
   
'عمل حلقة تكرار بعدد صفوف البيانات في الورقة الرئيسية
For r = 6 To wk_Row

'تحميل متغير التفضيلات بعد حذف منصرف ليتناسب مع الورقة المرسل لها
nsh = Trim(Mid(wk.Range("C" & r), 6, Len(wk.Range("C" & r))))

'حلقة تكرار الاورق المراد الإرسال لها
For Each WshtNameCrnt In WshtNames
  
'  مقارنة بند التفضيلات مع ورقة العمل
If Worksheets(WshtNameCrnt).Name = nsh Then

'  في حال انطبق اشرط ارسال بند التفضيلات إلى ورقة العمل
        With Worksheets(WshtNameCrnt)
        wk1_Row = .Range("B10000").End(xlUp).Row
        .Range("B" & wk1_Row + 1) = wk.Range("C" & r)
        .Range("C" & wk1_Row + 1) = wk.Range("G" & r)
        End With

End If


   Next
  
  Next

'اضافة المجموع
  For Each WshtNameCrnt In WshtNames
        With Worksheets(WshtNameCrnt)
        
        wk1_Row = .Range("B10000").End(xlUp).Row
         .Range("B" & wk1_Row + 1) = "المجموع"
        .Range("c" & wk1_Row + 1) = "=SUM(C3:C" & wk1_Row & ")"

        End With
   Next
 
End Sub

 

[Muner]

شكرا جزيلا اخي أبو احمد 

الشيء الاخر في عمود التفصيلات وهو العمود c اريد ما اكتبه في هذا العمود يترحل لكن الذي حصل انه مقيد بعبارة ( منصرف الأول ، منصرف الثاني وهكذا الثالث فلو كتبت عبارة الاول فقط او الثاني فقط او اي عبارة اخرى لم يتم الترحيل انا اريد اي عبارة اكتبها في خانة التفصيلات تترحل وليس مقيد بعبارة منصرف 

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

[أبوأحـمـد]

18 ساعات مضت, Muner said:

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

 

حساب المدرسة.xlsm

[Muner]

جزاك الله خيرا اخي ابو احمد