محمد هشام.

تفضل اخي Private Sub Select_and_Copy_File1_Click() Dim file As Variant Dim copyToFolder As String Dim p As Long Dim filePath As String filePath = Application.ActiveWorkbook.path file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه") If file = False Then Exit Sub On Error Resume Next MkDir filePath & "\" & "اوفيسنا" ' إنشاء نسخة في مجلد آخر copyToFolder = filePath & "\" & "اوفيسنا" ' If copyToFolder <> Left(file, InStrRev(file, "\")) Then p = InStrRev(file, "\") If Right(copyToFolder, 1) = "\" Then p = p + 1 FileCopy file, copyToFolder & Mid(file, p) Else 'إنشاء نسخة في نفس المجلد - اظافة "نسخة من " الى اسم الملف p = InStrRev(file, ".") FileCopy file, Left(file, p - 1) & "نسخة من" & Mid(file, p) End If MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & copyToFolder & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات" End Sub او بهدا الشكل Private Sub Select_and_Copy_File_Click() Dim MH As String, folder As String, p As String, NwPath As String Dim file As Variant Dim copyToFolder As String Set wb = ThisWorkbook p = wb.Path & "\" 'هنا قم باختيار اسم المجلد الدي سيتم انشاءه MH = "اوفيسنا" NwPath = p & MH folder = Dir(NwPath, vbDirectory) If folder = vbNullString Then VBA.FileSystem.MkDir (NwPath) End If file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه") If file = False Then Exit Sub copyToFolder = filePath If copyToFolder <> Left(file, InStrRev(file, "\")) Then p = InStrRev(file, "\") If Right(NwPath, 1) = "\" Then p = p + 1 FileCopy file, NwPath & Mid(file, p) End If MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & NwPath & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات" End Sub الارشيف الاكترونى_v2.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub test1() Dim Dernlige As Long Dim wsData As Worksheet Dim wsDest As Worksheet Dim lr As Long Dim i As Integer Application.ScreenUpdating = False Set wsData = Worksheets("Date Sales") Set wsDest = Worksheets("sales") lr = wsData.Cells(Rows.Count, "A").End(xlUp).Row + 1 For i = 3 To lr If Cells(i, 5) <> "" Then Dernlige = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row Range(Cells(i, 1), Cells(i, 6)).Copy Destination:=wsDest.Cells(Dernlige, 1) End If Next i wsData.Range("A3:F" & lr).ClearContents End Sub Book1_v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي احمد أغذية =SI(E11="";"";SI([@[Finnish Prodect ]]="FP";SOMME.SI.ENS(Q11:Q100;H11:H100;$H11;I11:I100;$I11;X11:X100;"*أغذية*"))) جينرال =SI(E11="";"";SI([@[Finnish Prodect ]]="FP";SOMME.SI.ENS(Q11:Q100;H11:H100;$H11;I11:I100;$I11;X11:X100;"جينرال"))) معادلة Sumifs_01.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي يمكنك استخدام المعادلة التالية =SI(A1<>"";SIERREUR(INDEX(Sheet1!$B$1:$B$50000; EQUIV(0; SI(A1=Sheet1!$A$1:$A$50000; NB.SI(Sheet1!$C$1:$C1; Sheet1!$B$1:$B$50000); ""); 0));"");"") حل اخر بالاكواد Sub Test() Dim I As Integer, Cellule As Range With Feuil2 For I = 1 To .Range("A" & Rows.Count).End(xlUp).Row Set Cellule = Feuil1.Cells.Find(What:=Range("A" & I), LookAt:=xlPart) If Not Cellule Is Nothing Then .Range("b" & I) = Cellule.Offset(0, 1).Value Next I End With End Sub مثال1.xlsm

وعليكم السلام ورحمة الله وبركاته على حسب ما فهمت أخي أفضل طريقة تمكنك للحصول على قوائم مترابطة تفلتر بعضها عليك أولا تنظيم قاعدة البيانات والاكتفاء فقط ب 3 أعمدة مثلا عمود A يتضمن جميع اسماء الشركات ويقابل كل شركة في عمود b الاصناف الخاصة بها ونفس الشيئ مع العنصر الثالث

تفضل اخي Private Sub Worksheet_Change(ByVal Target As Range) Dim WRng As Range, WRng2 As Range Dim rg As Range, rg2 As Range Dim ST1 As Integer, ST2 As Integer Set WRng = Intersect(Application.ActiveSheet.Range("B8:B1000"), Target) Set WRng2 = Intersect(Application.ActiveSheet.Range("d8:d1000"), Target) On Error Resume Next ST1 = 1 ST2 = 1 If Not WRng Is Nothing Then Application.EnableEvents = False For Each rg In WRng If Not VBA.IsEmpty(rg.Value) Then rg.Offset(0, ST1).Value = Now rg.Offset(0, ST1).NumberFormat = "dd-mm-yyyy HH:mm" Else rg.Offset(0, ST1).ClearContents End If Next Application.EnableEvents = True End If If Not WRng2 Is Nothing Then Application.EnableEvents = False For Each rg2 In WRng2 If Not VBA.IsEmpty(rg2.Value) Then rg2.Offset(0, ST2).Value = Now rg2.Offset(0, ST2).NumberFormat = "dd-mm-yyyy HH:mm" Else rg2.Offset(0, ST2).ClearContents End If Next Application.EnableEvents = True End If End Sub مسحوبات الخطوط.xlsm

العفو اخي لاكن لكل حق حقه المفروض أفضل إجابة تكون لصاحب الكود الأستاذ @lionheart أنا فقط قمت بتعديل بسيط جدا ليتناسب مع طلبك الأخير

بعد ادن الاستاد @lionheart اخي @ابو هاله النبلسي تم تعديل بسيط على الكود لتتمكن من تنفيد المطلوب تقسيم_2.xlsm

هل تقصد توزيع الصفوف بشرط قيمة خلية معينة ادا كان كدالك ما هي الخلية المطلوبة

تفضل اخي جرب Sub Copy_Paste1() Application.ScreenUpdating = False Sheets("Sheet2").Range("K15").Value = Sheets("Sheet1").Range("S2").Value Application.CutCopyMode = False 'Application.Run "Advance.xlsm!svpdf" End Sub او Sub Copy_Paste2() Application.ScreenUpdating = False Sheets("Sheet1").Range("s2").Copy Sheets("Sheet2").Range("k15").PasteSpecial xlPasteValues Application.CutCopyMode = False 'Application.Run "Advance.xlsm!svpdf" End Sub test01.xlsm

أخي @ehabaf2 هذه مسألة طبيعية خاصة عند وجود بيانات كثيرة على ورقة العمل من الأفضل إستبدال طريقة تنفيذ الكود من حدث الشيت إلى Module Sub Masquer_Columns() StartColumn = 6 ' اول عمود LastColumn = 176 ' اخر عمود iRow = 20 ' رقم الصف Application.ScreenUpdating = False For i = StartColumn To LastColumn If Range("B20").Value = "" Then 'From column 6 to column 170 Columns("F:FS").EntireColumn.Hidden = False Exit Sub End If If Cells(iRow, i).Value > Range("b20").Value Then Cells(iRow, i).EntireColumn.Hidden = True Else Cells(iRow, i).EntireColumn.Hidden = False End If Next i Application.ScreenUpdating = True End Sub كود اخفاء v2.xlsm

تفضل أستاد سعد. قد تم إضافة بعض المعادلات البسيطة لاستخراج التاريخ و تكست بوكس يتم إضافة تاريخ الغياب اليها تلقائيا عند إختيار اليوم مع ترحيله أمام إسم الطالب في شيت التجميع شيت البيانات الخلية .("AH2") . =EQUIV($AH$4;{"يناير";"فبراير";"مارس";"أبريل";"مايو";"يونيو";"يوليه";"أغسطس";"سبتمبر";"أكتوبر";"نوفمبر";"ديسمبر"};0) الخلية .(AH1") =SI(AH2<10;0&AH2;AH2) بالنسبة لليوزرفورم إليك الأكواد التالية Private Sub TARHIL_Click() Dim x As Range Dim lastRow As Long Dim WS2 As Range, WS1 As Range If ComboBox1.Text = Empty And ComboBox2 = Empty And TextBox1 = Empty Then MsgBox "المرجوا ادخال البيانات", Exclamation, "تنبيه" Exit Sub End If LR = Sheets("البيانات").Range("B" & Rows.Count).End(xlUp).Row LR2 = Sheets("تجميع الغياب").Range("B" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False 'التحقق من وجود اسم الطالب مسبقا لمنع التكرار في شيت البيانات Set WS1 = Sheets("البيانات").Range("B7:B" & LR).Find(what:=ComboBox1, LookIn:=xlValues, lookat:=xlWhole) If Not WS1 Is Nothing Then Set x = Cells.Find(ComboBox1.Value, , , 1) x.Offset(, ComboBox2.Value) = TextBox1.Value Else Range("B" & LR + 1) = ComboBox1 Set x = Cells.Find(ComboBox1.Value, , , 1) x.Offset(, ComboBox2.Value) = TextBox1.Value End If '''''''''''''''''''''''''''''''''''''''''''''''''''' Sheets("تجميع الغياب").Activate 'البحث عن الطالب ووضع تاريخ الغياب امام الاسم ' Set WS2 = Sheets("تجميع الغياب").Range("B6:B" & LR2).Find(what:=ComboBox1, LookIn:=xlValues, lookat:=xlWhole) If Not WS2 Is Nothing Then Cells(WS2.Row, "I").End(xlToLeft).Offset(, 1) = TextBox2.Text '("I") العمود ' لغايةاليوم السابع End If ComboBox1 = Empty ComboBox2 = Empty 'TextBox1 = Empty TextBox2 = Empty Sheets("البيانات").Activate End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub UserForm_Initialize() ' تعبئة كومبوبوكس 1 باسماء الطلاب بدون تكرار من شيت تجميع الغياب Set f = Sheets("تجميع الغياب") Set Réf = CreateObject("Scripting.Dictionary") a = f.Range("B6:B" & f.[B65000].End(xlUp).Row) For I = LBound(a) To UBound(a) If a(I, 1) <> Empty Then Réf(a(I, 1)) = Empty Next I WS2 = Réf.keys Me.ComboBox1.List = WS2 End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboBox2_Change() 'اظافة التاريخ Me.TextBox1.Text = "غ" If Me.ComboBox2.Value <= 9 Then Me.TextBox2.Text = Sheets("البيانات").Range("AH3").Text & "/" + Sheets("البيانات").Range("AH1").Text & "/" + "0" & ComboBox2.Text Else Me.TextBox2.Text = Sheets("البيانات").Range("AH3").Text & "/" + Sheets("البيانات").Range("AH1").Text & "/" & ComboBox2.Text End If End Sub تم إرفاق نسختين لنفس الملف ليبقى لك الإختيار في إظهار تكست التاريخ أو إخفائها دفتر الغياب.rar

هل هناك مانع بادخال التاريخ يدويا مثلا في تكست بوكس ويتم ترحيله امام اسم الطالب عند الترحيل

وعليكم السلام ورحمة الله وبركاته أستاذ سعد هل تقصد إضافة تاريخ اليوم أمام الإسم؟

استاد نظيم هل قمت بتجربة الكود الدي ارفقت في المشاركة واشتغل معاك

تفضل اخي Sub SSheet_2() Dim ws As Worksheet, Data As Worksheet, ShName As String Dim LR As Long, ER As Long, x As Integer Set Data = Sheets("المدخلات") Dim rng As Range ShName = Data.Range("C2").Text ER = Data.Range("B" & Rows.Count).End(3).Row x = ER - 7 Dim Plage As Range Dim i As Byte With Data Set Plage = Union(.Range("b10:b20"), .Range("b20")) For i = 1 To Plage.Count If Plage(i) = "" Then MsgBox ("يرجى ملا الخلية " & Plage(i).Address): Exit Sub Next End With For Each ws In Worksheets If ws.Name = ShName Then LR = ws.Range("B" & Rows.Count).End(3).Row ws.Name = ShName ws.Range("B" & LR + 1).Resize(x, 11) = Data.Range("B10").Resize(x, 11).Value End If Next End Sub test.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اخي الفاضل تم عمل المطلوب لاكن سوف اشرح لك الخطوات للاستفادة لنتمكن من عدم اظهار الغرف الساكنة على Combobox لابد اولا من الحصول على قائمة باسماءالغرف الفارغة (Avalable ) بما انني لاحظت انك واضع معادلة في شيت 1 لاستخراج (Room Statuse) بشرط التاريخ سوف نعتمد عليها ودالك باظافة عمود مساعد نضع فيه المعادلة التالية وليكن مثلا عمود ("X") لاستخراج الغرف الفارغة . =IF(E2="Available ";A2;"") بمعنى غند التحقق من الغرفة فارغة يتم استخراج اسمها في العمود المساعد وادا كانت محجوزة (Booked) نحصل على فراغ .وهكدا تتولد لدينا قائمة باسماء جميع الغرف الفارغة الخطوة الثانية والمهمة لابد من استبدال كود جلب البيانات بالكود التالي ليتم تعيئة الكومبوبوكس بالقيم المحصل عليها بدون فراغات Dim MH As Integer Dim Plage As Range 'جلب الغرف الفارغة With Sheets("sheet1") For MH = 2 To .Range("X" & .Rows.Count).End(xlUp).row If .Range("X" & MH) <> "" Then cmbroom.AddItem .Range("X" & MH) End If Next MH End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'تم إستبدال كود كومبو بوكس البحث بالكود التالي With Sheets("Database") Set Plage = .Range("b2:b" & .Range("b65536").End(xlUp).row) End With ComboBox1.List = Plage.Value بالتوفيق Reservation Form_V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب مصنف2.xlsx

بما انك مصر على نفس الفكرة ونفس اليوزرفورم تفضل اخي يمكنك تغيير الاكواد بالشكل التالي تمت اظافة كومبوبوكس لاختيار عمود البحث و تكست بوكس للبحث بالحروف الاولى Dim f, rng, MH(), Ncol '21/02/2022 اوفيسنا Private Sub UserForm_Initialize() Dim ST Set f = Sheets("Follow up") Set rng = f.Range("A5:J" & f.[A65000].End(xlUp).Row) MH = rng.Value ST = f.[A4].CurrentRegion.Columns.Count Me.ListBox1.ColumnCount = ST Set plage = f.[A4].CurrentRegion Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1) x = Me.ListBox1.Left + 8 y = Me.ListBox1.Top - 12 For i = 1 To ST Set Lab = Me.Frame1.Controls.Add("Forms.Label.1") Lab.Caption = f.Cells(4, i) Lab.Top = y Lab.Left = x x = x + f.Columns(i).Width * 1.02 temp = temp & f.Columns(i).Width * 1.02 & ";" Next temp = Left(temp, Len(temp) - 1) Me.ListBox1.ColumnWidths = temp Me.Frame1.ScrollWidth = Me.ListBox1.Width + 10 Me.Frame1.ScrollBars = 1 ' Me.ListBox1.List = plage.Value ' يمكنك تفعيل هدا الخيار لاظهار البيانات على الليست بوكس Me.ComboChoixColFiltre.List = Application.Transpose(rng.Offset(-1).Resize(1)) Me.ComboChoixColFiltre.ListIndex = 0 Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboChoixColFiltre_click() Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub CommandButton1_Click() If Recherche.Value = Empty Then MsgBox "المرجوا ادخال معيار البحث", vbInformation + vbMsgBoxRight + vbMagBoxRt1Reading, "تعليمات" Exit Sub End If colRecherche = Me.ComboChoixColFiltre.ListIndex + 1 clé = "*" & Me.Recherche & "*": N = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, colRecherche) Like clé Then N = N + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To N) For k = 1 To UBound(MH, 2): Tbl(k, N) = MH(i, k): Next k End If Next i If N > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Recherche_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then Recherche.Value = Empty End If End Sub ملاحظة البحث يكون فقط على نفس الشيت Test_User.xlsm

المرجوا الإجابة عن السؤال أولا هل البحث في جميع الأوراق أو ورقة واحدة لانه هناك اختلاف في الاكواد

تمام انت الان قمت بإضافة معيار آخر هل البحث سيكون في عدة شيتات أم شيت واحد. وهل ملفك الاصلي نفس نطاق هذا الملف علشان لا نظطر للتعديل مرة أخرى

اخي الطريقة الصحيحة هي اظهار البيانات على الليست بوكس وتحديد الاعمدة المرغوب الفلترة عليها بواسطة الكومبوبكس بطريقة دينامكية (مترابطة ) دون الاعتماد على قوائم اظافية مع وضع تيكست بوكس تقوم بفلترة البيانات بمجرد الكتابة دون الظغط على ازرار . 2) الملف غير منظم مما يشكل صعوبة لفهم المطلوب جيدا ربما كان من الافضل فقط تصميم يوزرفورم وطلب المساعدة بتكملت الاكواد احسن من التعديل على ملف قديم لا يناسب طلبك .

تفضل اخي تم تعديل كود الترحيل والتعديل معا ليتناسب مع الاضافات الجديدة Private Sub Modify_data_Click() 'تعديل Set WS = Sheet1 If TextBox1.Text = "" Then MsgBox "برجاء ادخال الرقم" Exit Sub Else Dim x As Long Dim y As Long x = WS.Range("A" & Rows.Count).End(xlUp).Row For y = 2 To x If WS.Cells(y, 1).Value = Me.recherch.Text Or WS.Cells(y, 2).Value = Me.recherch2.Text Then WS.Cells(y, 1).Value = Me.TextBox1.Value WS.Cells(y, 2).Value = Me.TextBox2.Value WS.Cells(y, 3).Value = Me.TextBox3.Value WS.Cells(y, 4).Value = Me.TextBox4.Value WS.Cells(y, 5).Value = Me.TextBox5.Value WS.Cells(y, 6).Value = Me.TextBox6.Value WS.Cells(y, 9).Value = Me.TextBox7.Value WS.Cells(y, 10).Value = Me.TextBox8.Value WS.Cells(y, 11).Value = Me.TextBox9.Value WS.Cells(y, 21).Value = Me.Label11.Caption End If Next y For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" End If Next ctrl Me.recherch.Value = "" Me.Label11.Caption = "" Me.Image1.Picture = LoadPicture(Label11.Caption) Me.ListBox1.Visible = False End If MsgBox "تم تعديل البيانات", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تأكيد" End Sub Private Sub Data_transfer_Click() 'ترحيل Dim sh As Worksheet Dim lr As Long Set sh = Sheet1 'ThisWorkbook.Sheets("نشاط") lr = sh.Range("A" & Rows.Count).End(xlUp).Row If UserForm4.TextBox1.Text = "" Then MsgBox "برجاء ادخال البيانات" Exit Sub End If With sh .Cells(lr + 1, "A").Value = Me.TextBox1.Text .Cells(lr + 1, "B").Value = Me.TextBox2.Text .Cells(lr + 1, "C").Value = Me.TextBox3.Text .Cells(lr + 1, "D").Value = Me.TextBox4.Text .Cells(lr + 1, "E").Value = Me.TextBox5.Text .Cells(lr + 1, "F").Value = Me.TextBox6.Text .Cells(lr + 1, "I").Value = Me.TextBox7.Text .Cells(lr + 1, "J").Value = Me.TextBox8.Text .Cells(lr + 1, "K").Value = Me.TextBox9.Text .Cells(lr + 1, "U").Value = UserForm4.Label11.Caption End With For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Value = "" End If Next ctrl Me.recherch = Empty Me.Label11.Caption = Empty Me.Image1.Picture = LoadPicture(Label11.Caption) MsgBox "تم ترحيل البيانات بنجاح ", Exclamation, "محمود الطحاوي" End Sub طلب تعديل يوزيرفورم 5.xlsm

العفو اخي الكريم بما انني استطعت استعاب المطلوب اليك الكود النهائي للملف ربما اسرع عند انشاء عدد كبير من اوراق العمل Public Sub MH_2() Dim ws As Worksheet, WS1 As Worksheet Dim arr As Variant, MH1 As Variant Dim lngArr As Long, lr As Long Dim MH2 As String Dim rngCell As Range temps = Timer 'باستثناء الاوراق التالية MH2 = "Vehicle,Data,Sample" Set WS1 = Sheet1 lr = WS1.Range("H" & WS1.Rows.Count).End(xlUp).Row arr = WS1.Range("H2:H" & lr).Value Application.ScreenUpdating = False ' اظهار النمودج Sheet2.Visible = True 'حدف اوراق العمل For Each ws In Worksheets If InStr(1, MH2, ws.Name) = 0 Then MH1 = Application.Match(ws.Name, arr, 0) If IsError(MH1) Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If End If Next ws ' نسخ For lngArr = LBound(arr) To UBound(arr) If Len(Trim(arr(lngArr, 1))) > 0 Then If Not Evaluate("ISREF('" & arr(lngArr, 1) & "'!A1)") Then Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = arr(lngArr, 1) ' تسمية اوراق العمل Range("i19").Value = arr(lngArr, 1) '("i19") اضافة اسم ورقة العمل للخلية ' End If End If Next lngArr ' حدف الارتباطات السابقة With Sheet1 .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).ClearContents Set rngCell = .Range("B2") End With 'إنشاء ارتباطات تشعبية على بيانات الاوراق الجديدة For Each ws In ActiveWorkbook.Worksheets If InStr(1, MH2, ws.Name) = 0 Then rngCell.Hyperlinks.Add Anchor:=rngCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name Set rngCell = rngCell.Offset(1) End If Next ws Set rngCell = Nothing Set WS1 = Nothing ' اخفاء النمودج Sheet2.Visible = False Sheet1.Activate Application.ScreenUpdating = True MsgBox "تم انشاء" & " " & Application.Sheets.Count - 3 & " " & "ورقة عمل جديدة " & "-" & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000") & "ثانية", Exclamation, "Officena" End Sub Personal_V2.xlsm