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

[ahmedadekabdulkader]

Sub AAD_ASD()
Dim R As Integer, M As Integer, N As Integer, O As Integer, p As Integer, Q As Integer, S As Integer, T As Integer
Sheets("ßåÑÈÇÁ").Range("A4:DZ1000").ClearContents
Sheets("ãíßÇäíßÇ").Range("A4:DZ1000").ClearContents
Sheets("äÌÇÑÉ ÃËÇË").Range("A4:DZ1000").ClearContents
Sheets("ÒÎÑÝÉ").Range("A4:DZ1000").ClearContents
Sheets("ÕÍí").Range("A4:DZ1000").ClearContents
Sheets("ÅäÔÇÁÇÊ").Range("A4:DZ1000").ClearContents
Sheets("äÊÔØíÈÇÊ").Range("A4:DZ1000").ClearContents
M = 4: N = 4: O = 4: p = 4: Q = 4: S = 4: T = 4
Application.ScreenUpdating = False
For R = 4 To 1000
If Cells(R, 4) = "ßåÑÈÇÁ" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("ßåÑÈÇÁ").Range("A" & M).PasteSpecial xlPasteValues
Sheets("ßåÑÈÇÁ").Range("A" & M).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
M = M + 1
ElseIf Cells(R, 4) = "ãíßÇäíßÇ" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("ãíßÇäíßÇ").Range("A" & N).PasteSpecial xlPasteValues
Sheets("ãíßÇäíßÇ").Range("A" & N).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
N = N + 1
ElseIf Cells(R, 4) = "äÌÇÑÉ ÃËÇË" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("äÌÇÑÉ ÃËÇË").Range("A" & O).PasteSpecial xlPasteValues
Sheets("äÌÇÑÉ ÃËÇË").Range("A" & O).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
O = O + 1
ElseIf Cells(R, 4) = "ÒÎÑÝÉ" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("ÒÎÑÝÉ").Range("A" & p).PasteSpecial xlPasteValues
Application.CutCopyMode = False
p = p + 1
If Cells(R, 4) = "ÕÍíÁ" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("ÕÍíÁ").Range("A" & Q).PasteSpecial xlPasteValues
Sheets("ÕÍí").Range("A" & Q).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Q = Q + 1
If Cells(R, 4) = "ÅäÔÇÁÇÊ" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("ÅäÔÇÁÇÊ").Range("A" & S).PasteSpecial xlPasteValues
Sheets("ÅäÔÇÁÇÊ").Range("A" & S).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
S = S + 1
If Cells(R, 4) = "ÊÔØíÈÇÊ" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("ÊÔØíÈÇÊ").Range("A" & T).PasteSpecial xlPasteValues
Sheets("ÊÔØíÈÇÊ").Range("A" & T).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
T = T + 1
End If
Next
MsgBox ("ÇáÍãÏ ááå ÊÜÜÜã ÊÑÍíá ÇáäÇÌÍíä æ ÇáÑÇÓíÓä Åáì ÃæÑÇÞ Úãá ÌÏíÏÉ ")
Application.ScreenUpdating = True
End Sub

 

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

يا اخي ارفع الملف نفسه وليس صورة

لا يمكن اكتشاف الخطأ ولا التصحيح على الصورة

[Ali Mohamed Ali]

لديك حق استاذى الكريم سليم فنبهنا كثيراً جداً على ضرورة رفع ملف بالمشاركة ولكن بعد اذن حضرتك -يمكنك استخدام الكود هكذا , فكان عليك وضع جملة End If بالكود ثلاثة

مرات أخرى قبل كلمة Next كما ترى

Sub AAD_ASD()
Dim R As Integer, M As Integer, N As Integer, O As Integer, p As Integer, Q As Integer, S As Integer, T As Integer
Sheets("كهرباء").Range("A4:DZ1000").ClearContents
Sheets("ميكانيكا").Range("A4:DZ1000").ClearContents
Sheets("نجارة أثاث").Range("A4:DZ1000").ClearContents
Sheets("زخرفة").Range("A4:DZ1000").ClearContents
Sheets("صحي").Range("A4:DZ1000").ClearContents
Sheets("إنشاءات").Range("A4:DZ1000").ClearContents
Sheets("تشطيبات").Range("A4:DZ1000").ClearContents
M = 4: N = 4: O = 4: p = 4: Q = 4: S = 4: T = 4
Application.ScreenUpdating = False
For R = 4 To 1000
If Cells(R, 4) = "كهرباء" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("كهرباء").Range("A" & M).PasteSpecial xlPasteValues
Sheets("كهرباء").Range("A" & M).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
M = M + 1
ElseIf Cells(R, 4) = "ميكانيكا" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("ميكانيكا").Range("A" & N).PasteSpecial xlPasteValues
Sheets("ميكانيكا").Range("A" & N).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
N = N + 1
ElseIf Cells(R, 4) = "نجارة أثاث" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("نجارة أثاث").Range("A" & O).PasteSpecial xlPasteValues
Sheets("نجارة أثاث").Range("A" & O).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
O = O + 1
ElseIf Cells(R, 4) = "زخرفة" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("زخرفة").Range("A" & p).PasteSpecial xlPasteValues
Application.CutCopyMode = False
p = p + 1
If Cells(R, 4) = "صحي" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("صحي").Range("A" & Q).PasteSpecial xlPasteValues
Sheets("صحي").Range("A" & Q).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Q = Q + 1
If Cells(R, 4) = "إنشاءات" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("إنشاءات").Range("A" & S).PasteSpecial xlPasteValues
Sheets("إنشاءات").Range("A" & S).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
S = S + 1
If Cells(R, 4) = "تشطيبات" Then
Range("A" & R).Resize(1, 115).Copy
Sheets("تشطيبات").Range("A" & T).PasteSpecial xlPasteValues
Sheets("تشطيبات").Range("A" & T).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
T = T + 1
End If
End If
End If
End If
Next
MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسيسن إلى أوراق عمل جديدة ")
Application.ScreenUpdating = True
End Sub

 

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

استاذ علي

لا ضرورة اكل هذه الحلقات التكرارية (من 4 الى 1000)

بكفي حلقة صغيرة جداُ حسب عدد الصفحات(7) كل حلقة تقوم بــ Auto filter على الجدول في  الصفحة الرئيسية حسب اسم كل صفحة

ثم نسخ الجدول مفلتراً الى الشيت المعنية (لهذا السبب انا طلبت الملف)

شيء يشبه هذا الكود

Option Explicit

Sub filter_Please()
Dim arr, Element
Dim Rg As Range
Set Rg = ActiveSheet.Range("A4").CurrentRegion
arr = Array("كهرباء", "ميكانيكا", "نجارة أثاث", _
"زخرفة", "صحي", "إنشاءات", "تشطيبات")
 For Each Element In arr
  Rg.AutoFilter , 4, Element
  Rg.SpecialCells(12).Copy
  Sheets(Element).Range("A4").PasteSpecial
 Next
 ActiveSheet.AutoFilterMode = False
End Sub