saad abed

مايو 6

اخى محمد هشام

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

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

مايو 5

السلام عليكم ورحمة الله وبركاته

فى الموضوع السابق تم عمل كود عن طريق اخى محمد هشام واخى عبدالله

يمكنى من حذف ملفات اكسيل ذات امتداد معين ونقله الى فولدر فى السى

واليوم

اطلب نفس الطريقة ولكن لتحويل الامتداد .xlsb الى .xlsx

كل الشكر للمشرفين والخبراء فى هذا المنتدى الحبيب

مايو 4

17 ساعات مضت, عبدالله بشير عبدالله said:

وعليكم السلام ورحمة الله تعالى وبركاته

جرب الكود التالي

اذا ظهر خطا بالكود ربما تحتاج تشغيل تطبيق اكسل كمسؤول

Sub DeleteXLSBFromDriveD()
    Dim folderPath As String
    folderPath = "D:\"
    
    Call DeleteXLSBRecursive(folderPath)
    
    MsgBox "تم حذف جميع ملفات .xlsb من الدرايف D (حذف).", vbInformation
End Sub

Sub DeleteXLSBRecursive(folderPath As String)
    Dim fs As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    On Error Resume Next
    Set folder = fs.GetFolder(folderPath)
    If folder Is Nothing Then
        Debug.Print "Cannot access folder: " & folderPath
        Exit Sub
    End If
    On Error GoTo 0

    On Error Resume Next
    Dim fileCount As Long
    fileCount = folder.Files.Count
    If Err.Number <> 0 Then
        Debug.Print "Error accessing files in: " & folderPath & " - " & Err.Description
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If
    On Error GoTo 0

    If fileCount > 0 Then
        For Each file In folder.Files
            On Error Resume Next
            If LCase(fs.GetExtensionName(file.Name)) = "xlsb" Then
                SetAttr file.Path, vbNormal
                Kill file.Path
                If Err.Number <> 0 Then
                    Debug.Print "Failed to delete: " & file.Path & " - Error: " & Err.Description
                    Err.Clear
                End If
            End If
            On Error GoTo 0
        Next file
    End If
    
    For Each subFolder In folder.SubFolders
        DeleteXLSBRecursive subFolder.Path
    Next subFolder
End Sub

اخى عبدالله

الكود يعمل بكفاءه

جزاك الله خيرا

مايو 4

12 ساعات مضت, محمد هشام. said:

ادن لنجرب طريقة أخرى

Option Explicit
Sub Testxlsb()
    Dim xPath As String, n As Double
    Dim startTime As Double, xList As String
    Dim sCount As Long, confirm As VbMsgBoxResult
    xPath = "D:\"
    xList = ""
    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual
    startTime = Timer

    tmps xPath, xList
    
    If xList = "" Then
        MsgBox "لم يتم العثور على أي ملفات بامتداد xlsb في " & xPath
    Else
    
        sCount = UBound(Split(Trim(xList), vbCrLf))
        
        confirm = MsgBox("تم العثور على " & sCount & " ملف بامتداد xlsb " & vbCrLf & _
                         "هل تريد حدفها ونقلها إلى  مجلد الملفات المحدوفة ؟", vbYesNo + vbQuestion)
        If confirm = vbYes Then
            tbl xPath, xList
            Snames xList
            MsgBox "تم الحذف وحفظ أسماء الملفات في  C:\الملفات المحدوفة\filName.txt"
        Else
            MsgBox "تم إلغاء العملية لم يتم حذف أي ملفات"
        End If
    End If
    
    .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
    End With
    n = Timer - startTime
    MsgBox "تم تنفيذ العملية في: " & Format(n, "0.00") & " ثانية"
End Sub

Sub tmps(ByVal xPath As String, ByRef xList As String)
    Dim fso As Object, Folder As Object, file As Object, sFiles As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next
    Set Folder = fso.GetFolder(xPath)
    If Folder Is Nothing Then Exit Sub
    On Error GoTo 0

    If Not Folder Is Nothing Then
        On Error Resume Next
        For Each file In Folder.Files
            If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then
                If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then
                    xList = xList & file.Path & vbCrLf
                End If
            End If
        Next
        On Error GoTo 0

        On Error Resume Next
        For Each sFiles In Folder.sFiless
            tmps sFiles.Path, xList
        Next
        On Error GoTo 0
    End If
End Sub

Sub tbl(ByVal xPath As String, ByRef xList As String)
    Dim fso As Object, Folder As Object, file As Object, sFiles As Object
    Dim CntFile As String, r As String, ky As Integer
    CntFile = "C:\الملفات المحدوفة\DeletedXLSB\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists("C:\الملفات المحدوفة\") Then fso.CreateFolder ("C:\الملفات المحدوفة\")
    If Not fso.FolderExists(CntFile) Then fso.CreateFolder (CntFile)
    
    On Error Resume Next
    Set Folder = fso.GetFolder(xPath)
    If Folder Is Nothing Then Exit Sub
    On Error GoTo 0

   On Error Resume Next
For Each file In Folder.Files
    If Err.Number = 0 Then
        If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then
            If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then
             
                r = CntFile & fso.GetFileName(file.Path)
                ky = 1
                While fso.FileExists(r)
                    r = CntFile & "Copy_" & ky & "_" & fso.GetFileName(file.Path)
                    ky = ky + 1
                Wend

                file.Move r
            End If
        End If
    End If
    Err.Clear
Next
    For Each sFiles In Folder.sFiless
        tbl sFiles.Path, xList
    Next
    On Error GoTo 0

End Sub

Sub Snames(xList As String)
    Dim fileNum As Integer
    fileNum = FreeFile
    On Error Resume Next
    Open "C:\الملفات المحدوفة\filName.txt" For Output As #fileNum
    Print #fileNum, xList
    Close #fileNum
    On Error GoTo 0
End Sub

TEST2.xlsm 19.35 kB · 6 downloads

اخى محمد هشام

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

مايو 4

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

اشفى ابن محمد هشام

اللهم امين

مايو 4

اخى عبدالله بشير عبدالله

اخى محمد هشام

كل الشكر والتقدير لكم اخوتى الاكارم

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

جزاكم الله خيرا

مايو 3

السلام عليكم اخى محمد

نعم اريد حذف ملفات الاكسيل ذات الامتداد .xlsb من دريف معين

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

مايو 3

السلام عليكم

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

مارس 4, 2023

السلام عليكم ورحمه الله وبركاته

جزاك الله كل خير استاذ ضاحي

فبراير 28, 2023

السلام عليكم ورحمه الله وبركاته

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

استمر والله اعمال رائعه

فبراير 21, 2023

اخى ضاحى

احسنت وجزاك الله خيرا

وصلت الفكره والله مفيده جدا

فبراير 14, 2023

السلام عليكم

يفضل اضافة سطر لمسح الداتا

Sht6.Range("A3:Q100000").ClearContents

فبراير 5, 2023

اخى

اكتب انت اسم الورقة

Private Sub CreateSheet()
    Dim ws As Worksheet
    ss = InputBox("name is ........")
    Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
     ws.Name = ss
End Sub

فبراير 3, 2023

جرب الاتى

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

فبراير 2, 2023

اخى

هذا الشرط يمنع مسح المجال لانه ينهى عمل الكود اذا تحقق الشرط

 If (sheet1.Cells(R, "b") = "") Then
'            Exit Sub
'        End If

جرب اوقف عمل الاسطر وجرب سترى ان كل شئ على ما يرام

فبراير 2, 2023

فهمت ما تريد

استخدمت مقسم العرض يعمل من اوفيس اعلى من 2010

اختار من مقسم العرض لعمود اكس تنشن

انسخ الرقم فى خليه h8

datea.xlsx

فبراير 1, 2023

اخى الكريم

غير اكواد التفريغ خارج الحلقه المتكرره

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") = ورقة1.Cells(2, "B")
ورقة3.Cells(Lrow, "B") = ورقة1.Cells(3, "B")
ورقة3.Cells(Lrow, "C") = ورقة1.Cells(4, "B")
ورقة3.Cells(Lrow, "D") = ورقة1.Cells(29, "D")
ورقة3.Cells(Lrow, "E") = ورقة1.Cells(29, "F")
ورقة3.Cells(Lrow, "F") = ورقة1.Cells(30, "F")
ورقة3.Cells(Lrow, "G") = ورقة1.Cells(31, "F")
ورقة3.Cells(Lrow, "H") = ورقة1.Cells(32, "F")
ورقة3.Cells(Lrow, "I") = ورقة1.Cells(33, "F")

Dim LastRow As Integer
Dim R As Integer

 For R = 7 To 27
  If (ورقة1.Cells(R, "b") = "") Then
  Exit Sub
  End If
  
   LastRow = ورقة2.Cells(ورقة2.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    
    ورقة2.Cells(LastRow, "A") = ورقة1.Cells(2, "B")
     ورقة2.Cells(LastRow, "B") = ورقة1.Cells(3, "B")
      ورقة2.Cells(LastRow, "C") = ورقة1.Cells(4, "B")
       ورقة2.Cells(LastRow, "D") = ورقة1.Cells(R, "B")
        ورقة2.Cells(LastRow, "E") = ورقة1.Cells(R, "C")
         ورقة2.Cells(LastRow, "F") = ورقة1.Cells(R, "D")
          ورقة2.Cells(LastRow, "G") = ورقة1.Cells(R, "E")
           ورقة2.Cells(LastRow, "H") = ورقة1.Cells(R, "F")
  
           
     Next
              
   ورقة1.Cells(2, "B") = ""
     ورقة1.Cells(3, "B") = ""
      ورقة1.Cells(4, "B") = ""
       ورقة1.Cells(R, "B") = ""
        ورقة1.Cells(R, "C") = ""
         ورقة1.Cells(R, "D") = ""
          ورقة1.Cells(R, "E") = ""
           ورقة1.Cells(R, "F") = ""
End Sub

فبراير 1, 2023

لعل هذا يكون المطلوب

ضع اى اضافة ما دامت ممكنه سيتم التعديل

datea.xlsx

يناير 31, 2023

في 28‏/1‏/2023 at 11:26, alsihran said:

ليس هذا المطلوب أخي الكريم

المطلوب عمل Pivot Tabels

واظهار الاعمدة s1 s2 s3 s4 s5 s6 s7 s8 s9 s10

وعد القيمة 2 لكل id_Ccallg من كل من عمود

شكرا لك

ارسل تصور للنتائج

تم عمل تقرير Pivot Tabels

عمود id_Ccallg اساس وشرط العد لكل الاعمده عد وليس جمع القيم

يناير 30, 2023

لعل هذا يكون المطلوب

المصنف1.xlsx

يناير 29, 2023

السلام عليكم ورحمة الله وبركاته
الفورم به استدعاء للصوره من اى مسار
فهل يمكن تغيير المسار وحفظ الصورة فى مسار اخر

المصنف1.xlsb

نوفمبر 12, 2022

اخى ضاحى

احسنت بارك الله فيكم

نوفمبر 8, 2022

اخى وجيه

اكرمكم الله ونفع بكم

نوفمبر 3, 2022

اخى الحبيب ضاحى

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

اود الاستفاده من طريقة كتابتك للاكواد اخى الحبيب

مع ان الكنترول 1 2 3 4 الى انك اخترت فى الحلقة التكراريه من 0 1 2 3 واعلم انك اضفت واحد +1

لما لم تستخدم من 4:1 حاولت اعطتنى خطا

For AddEvent = 0 To 3

Set LblEvent(AddEvent).LblBtn = Me("Btn" & AddEvent + 1)
Next AddEvent

لا اجد فى الكود ما يخفى اسماء التبويبات رغم انها تظهر فى التصميم ولا تظهر فى التشغيل page1 page2 page3 page4

نوفمبر 1, 2022

اخى ضاحى

ممتاز وبارك الله فيك

صيغ الصور بحيث لا تزيد مساحة البرنامج فى حالة وجود اكثر من فورم

وافضل برنامج لتصميم صور للفورم

جزاك الله خيرا

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

الوسائط المتعددة

مشاركات المكتوبه بواسطه saad abed

Important Information