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