الأساتذة الأفاضل خبراء اكسيل برجاء مساعدتنا فى فى إضافة السطر الموجود لأنى عند تشغيله يوقف عمل النسخ ولكم جزيل الشكر
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
