يا خبراء الأكواد سا عدونا

[yehya mahmoud]

الأساتذة الأفاضل خبراء اكسيل برجاء مساعدتنا فى فى إضافة السطر الموجود لأنى عند تشغيله يوقف عمل النسخ ولكم جزيل الشكر

Sub Tarheel()
Application.ScreenUpdating = False
prompt = "åá ÊÑíÏ ÊÍÏíË ÏÑÌÇÊ ÃÚãÇá ÇáÓäÉ"
Command_buttons = vbYesNo + VbMsgBoxRt1Reading
Title = "ÊÝÑíÛ æØÈÇÚÉ ÇáÏÑÌÇÊ"
project = MsgBox(prompt, Command_buttons, Title)
If project = vbYes Then
PT = ActiveWorkbook.Path
Application.DisplayAlerts = False
For SH = 20 To 24
nm = Format(SH, "@")
Sheets(nm).Activate
LR = [A9999].End(xlUp).Row
    Range("aa6:ca3930").Copy
    Workbooks.Open Filename:=PT & "\" & nm & ".xlsm"
'Sheets("maindata").Range("aa1:bc2000").UnMerge
                Sheets("maindata").Range("aa1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Sheets("maindata").Range("aa1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Close (True)
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Sheets("main").Select
MsgBox "Êã ÊÍÏíË ÏÑÌÇÊ ÃÚãÇá ÇáÓäÉ ÈäÌÇÍ"
Else
End If
Application.ScreenUpdating = True
End Sub

تم تعديل منذ 23 ساعات بواسطه kinguter1

[أبو قاسم]

ارفق ملف توضيحي لكي يتم التصحيح علية

[yehya mahmoud]

شكراً أخى أبو القاسم على الاهتمام

إليك المرفق التوضيحى والمطلوب موجود بالمصنف رقم 2

وكل عام أنتم بخير

 

ترحيل.rar