saad abed

اخى محمد هشام الكود يعمل بكفاءه عاليه جزاك الله خيرا اخى محمد عامل السرعه فى كود تحويل الملفات هل الغاء الرسائل يعمل على زيادة سرعة الكود

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

اخى عبدالله الكود يعمل بكفاءه جزاك الله خيرا

اخى محمد هشام تم التجريب الكود يعمل بكفاءة فى الملفات التى على الدرايف مباشرة اما التى داخل فولدرات فلا تتاثر بالكود

إللهم أذهب البأس ربّ النّاس، اشف وأنت الشّافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقماً، أذهب البأس ربّ النّاس، بيدك الشّفاء، لا كاشف له إلّا أنت يارب العالمين اشفى ابن محمد هشام اللهم امين

اخى عبدالله بشير عبدالله اخى محمد هشام كل الشكر والتقدير لكم اخوتى الاكارم جارى التجربه ولكن مجهودكم كبير تشكرون عليه جزاكم الله خيرا

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

السلام عليكم هل هناك كود يمكنى من الالغاء ملفات اكسيل بامتداد معين مثلا .xlsb فى درايف معين او فى كل الدريفات

السلام عليكم ورحمه الله وبركاته جزاك الله كل خير استاذ ضاحي

السلام عليكم ورحمه الله وبركاته احسنت وجزاك الله عنا خير الجزاء استمر والله اعمال رائعه

اخى ضاحى احسنت وجزاك الله خيرا وصلت الفكره والله مفيده جدا

السلام عليكم يفضل اضافة سطر لمسح الداتا Sht6.Range("A3:Q100000").ClearContents

اخى اكتب انت اسم الورقة Private Sub CreateSheet() Dim ws As Worksheet ss = InputBox("name is ........") Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) ws.Name = ss End Sub

جرب الاتى Sub SaveBill() On Error Resume Next Dim Lrow As Integer Lrow = ورقة3.Cells(ورقة3.Rows.Count, "a").End(xlUp).Offset(1, 0).Row ورقة3.Cells(Lrow, "A") = sheet1.Cells(2, "B") ورقة3.Cells(Lrow, "B") = sheet1.Cells(3, "B") ورقة3.Cells(Lrow, "C") = sheet1.Cells(4, "B") ورقة3.Cells(Lrow, "D") = sheet1.Cells(29, "D") ورقة3.Cells(Lrow, "E") = sheet1.Cells(29, "F") ورقة3.Cells(Lrow, "F") = sheet1.Cells(30, "F") ورقة3.Cells(Lrow, "G") = sheet1.Cells(31, "F") ورقة3.Cells(Lrow, "H") = sheet1.Cells(32, "F") ورقة3.Cells(Lrow, "I") = sheet1.Cells(33, "F") Dim LastRow As Integer Dim R As Integer '''''''''''''''''''''''''''''''' For R = 7 To 27 If (sheet1.Cells(R, "b") <> "") Then LastRow = ورقة2.Cells(ورقة2.Rows.Count, "A").End(xlUp).Offset(1, 0).Row ورقة2.Cells(LastRow, "A") = sheet1.Cells(2, "B") ورقة2.Cells(LastRow, "B") = sheet1.Cells(3, "B") ورقة2.Cells(LastRow, "C") = sheet1.Cells(4, "B") ورقة2.Cells(LastRow, "D") = sheet1.Cells(R, "B") ورقة2.Cells(LastRow, "E") = sheet1.Cells(R, "C") ورقة2.Cells(LastRow, "F") = sheet1.Cells(R, "D") ورقة2.Cells(LastRow, "G") = sheet1.Cells(R, "E") ورقة2.Cells(LastRow, "H") = sheet1.Cells(R, "F") End If Next '''''''''''''''''''''''''''''''''''''''' sheet1.Range("b2").ClearContents sheet1.Range("b3").ClearContents sheet1.Range("b4").ClearContents sheet1.Range("b7:e27").ClearContents End Sub غيرت اسم الورقة من ورقه1 الى sheet1

اخى هذا الشرط يمنع مسح المجال لانه ينهى عمل الكود اذا تحقق الشرط If (sheet1.Cells(R, "b") = "") Then ' Exit Sub ' End If جرب اوقف عمل الاسطر وجرب سترى ان كل شئ على ما يرام