حسونة حسين

يمكنك الاستفاده من هذا الموضوع

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

بارك الله فيك اخى @ابو عبد الرحمن. 

وجعله الله في ميزان حسناتك يوم القيامة

جزاكم مثله استاذ

@أ / محمد صالح عمل ممتاذ بارك الله فيك 

وفيك بارك اخي

@Ali Mohamed Ali

جزاكم الله خيرا ابو يوسف

@محمد حسن المحمد على دعاؤك الطيب

وجزاكم مثله ابو عبدالرحمن @علي بطيخ سالم

وفيك بارك استاذنا الغالي @ياسر خليل أبو البراء

تشرفت بمروركم الكريم

بسم الله الرحمن الرحيم

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

اساتذتي واخوتى

هذا الملف به فهرس لجميع المنتدي ليسهل البحث للاعضاء

يوجد فورم يمكنك البحث بها

كما يمكنكم استخدام الفلتر العادي

وبمجرد الضغط على اي نتيجه من نتائج البحث يتم فتح صفحتها في المنتدي

ولا انسي فضل استاذي الكبير ياسر خليل على المساعده في عمل الملف

فهرس منتدي الاكسيل.xlsb

اخي @الموسطي

هذا الطلب غير طلبك في المشاركه الاولي بهذا الموضوع

يرجي فتح موضوع جديد بالطلب الجديد

اداره المنتدي ترسل لك تحذير بان الموضوع مكرر 

اخي @mohamedyousef

انت بتسأل سؤال بيكون هو نفس سؤالك في موضوع تاني قد جاوبك عليه الاساتذه

او يجتهدوا لك في الاجابه عليه

فتستعجل الاجابه فتقوم بفتح موضوع جديد بنفس السؤال فترسل لك الاداره تحذير بان الموضوع مكرر

وهذه قواعد المشاركة فى الموقع

يمكنك الضغط هنـــــــــا لقراءة القواعد كاملة
و بصفة خاصة نؤكد على ما يلي
1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة
2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد.
3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال.
4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا.....
5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم.
ومخالفة ذلك تعرض الموضوع للحذف

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

قم اخي بفتح موضوع جديد بهذا الطلب

عدل هذا السطر

If .AutoFilterMode Then
   .ShowAllData
End If

الى

If .AutoFilterMode Then
On Error Resume Next
    .ShowAllData
On Error GoTo 0
End If

والافضل من هذا

من الواضح ان الاوفيس الخاص بك ٢٠٠٧

قم بتغيير الاوفيس من ٢٠٠٧

الى اوفيس اعلى وليكن ٢٠١٠

مش عايز اقولك ٢٠٢١

لان الكود يعمل عندى بدون مشاكل على اوفيس٢٠١٠

ازل علامه الصح

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

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

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

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

اخي @ابوعلي الحبيب

في 12‏/7‏/2023 at 00:18, علي بن علي said:

هناك بعض الطرق اشهرها تثبيت بعض المكتبات لدعم اكسيل

كمكتبة selenium 

التي تعمل كمنسق للتعامل بين اكسيل مع متصفح كروم او واتساب ويب

لو حابب الحل عن طريق السيلينيوم اجهز لك كود ان شاء الله

جرب هذا التعديل

900.xlsm

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

12 ساعات مضت, ehabaf2 said:

عند ترحيل تقيم الطلاب يتم مسح درجات التقيم فقط من العمود F الى العمود O و لا يتم مسح بيانات الطلاب

تفضل هذا التعديل

Option Explicit

Sub Tarhil()
    Dim WS As Worksheet, ARR, LR As Long, P As Long, i As Long, J As Long, K As Long
    Set WS = ThisWorkbook.Worksheets("التسجيل")
    P = 1
    LR = WS.Range("A" & Rows.Count).End(xlUp).Row
    ARR = WS.Range("B10:R" & LR).Value
    ReDim Temp(1 To LR + 1, 1 To UBound(ARR, 2))
    
    For i = 1 To UBound(ARR)
        For J = 5 To 15
            If ARR(i, J) <> "" Then
                For K = 1 To 17
                    Temp(P, K) = ARR(i, K)
                Next K
                P = P + 1
                Exit For
            End If
        Next J
    Next i

    With WS
        If P > 0 Then
            .Range("F10:O" & LR).ClearContents
            .Columns("AP").NumberFormat = "@"
            .Columns("BC").NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
            LR = Application.Max(9, .Cells(.Rows.Count, "AM").End(xlUp).Row)
            .Range("AM" & LR + 1).Resize(P - 1, UBound(Temp, 2)).Value = Temp
        End If
    End With
End Sub

2 ساعات مضت, ehabaf2 said:

ملحوظة انا لم استخدم هذا الجزء و لم اعرف فيما يستخدم

Application.Goto .Range("AM" & m), True

جعل مرشر الماوس يذهب الي اول خليه تم ترحيلها في العامود AM

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

استبدل الاكواد في فورم 8 بهذه الاكواد

Private Sub CommandButton1_Click()
    Dim LRow As Long
    Dim namsh As String
    Dim wk, wk2 As Worksheet
    Dim x As Integer
    Dim check As Boolean
    namsh = "temp"
    Set wk = ThisWorkbook.Worksheets("التكويد")

    For Each wk2 In ThisWorkbook.Worksheets
        If wk2.Name Like namsh Then check = True: Exit For
    Next
    If check = False Then

        With ThisWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh
        End With
    End If

    Set wk2 = ThisWorkbook.Worksheets(namsh)
    wk2.Range("A1:E9999") = ""
    LRow = wk.Range("A999").End(xlUp).Row

    wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1")

    With wk2
        Rowz = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & Rows(Rows.Count).End(xlUp).Row))
        .Range("B" & Rowz + 2) = "الاجمالي"
        .Range("C" & Rowz + 2) = "=ROUND(SUM(C2:C" & Rowz + 1 & "),2)"
        .Range("D" & Rowz + 2) = "=ROUND(SUM(D2:D" & Rowz + 1 & "),2)"
        .Range("E" & Rowz + 2) = "=ROUND(SUM(E2:E" & Rowz + 1 & "),2)"
        .Columns("A:E").AutoFit

        With wk2.Range("B" & Rowz + 2 & ":E" & Rowz + 2)
            .AddIndent = True
            .Font.FontStyle = "Times New Roman"
            .Font.Size = 16
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Interior.Color = RGB(237, 237, 220)
            .Font.Bold = False
            .Font.Bold = True
        End With
        .PageSetup.PrintArea = "A1:E" & Rowz + 2    'LRow
        Application.Dialogs(xlDialogPrint).Show
    End With
    Application.DisplayAlerts = False
    If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub
    If Evaluate("=ISREF('" & namsh & "'!A1)") Then
        Sheets(namsh).Delete
    End If
    Application.DisplayAlerts = True
    wk.Activate
End Sub

Private Sub CommandButton2_Click()
    With ThisWorkbook.Worksheets("التكويد")
        With .Range("A1:T1")
            If Me.ComboBox1.Text = "" Then Exit Sub
            .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text & "*"
        End With
        Call CommandButton1_Click
        If .AutoFilterMode Then
            .ShowAllData
        End If
    End With
End Sub

Private Sub CommandButton3_Click()
    Unload Me
End Sub

Private Sub UserForm_Activate()
    Dim wk As Worksheet
    Dim v, e
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
    Set wk = ThisWorkbook.Worksheets("التكويد")
    LRow = wk.Range("A999").End(xlUp).Row
    v = wk.Range("C2:C" & LRow).Value
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For Each e In v
            If Not .exists(e) Then .Add e, Nothing
        Next
        If .Count Then Me.ComboBox1.list = Application.Transpose(.keys)
    End With
End Sub

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

تفضل اخى

Option Explicit

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet, ARR, LR As Long, P As Long, i As Long, J As Long, K As Long, R As Range
    Set WS = ThisWorkbook.Worksheets("التسجيل")
    Set SH = ThisWorkbook.Worksheets("التقيم")
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    P = 1
    ARR = WS.Range("A10:R" & WS.Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim Temp(1 To LR + 1, 1 To UBound(ARR, 2))
    For i = 1 To UBound(ARR)
        For J = 5 To 15
            If ARR(i, J) <> "" Then
                Temp(P, 1) = WorksheetFunction.Max(Columns("AM")) + P
                For K = 2 To 18
                    Temp(P, K) = ARR(i, K)
                Next K

                If R Is Nothing Then
                    Set R = WS.Cells(i + 9, 1)
                Else
                    Set R = Union(R, WS.Cells(i + 9, 1))
                End If

                P = P + 1
                Exit For
            End If
        Next J
    Next i
    If Not R Is Nothing Then R.EntireRow.Delete
    With SH
        If P > 0 Then
            .Columns("AP").NumberFormat = "@"
            .Columns("BC").NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
            LR = Application.Max(2, .Cells(Rows.Count, "AM").End(xlUp).Row)
            .Range("AM" & LR).Resize(P - 1, UBound(Temp, 2)).Value = Temp
        End If
    End With
End Sub

اخى لكل موضوع طلب منفصل

مرفق بملف بعد ما تقوم بإدخال الاكواد التى انتهيت منها 

موضحا ما تريد

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

اخى @ابو .. عبدالرحمن

لكل طلب موضوع منفصل

هذا طلبك الاول كود الترحيل (ادخال البيانات)

Option Explicit
Private arr As Variant, Temp As Variant, X
Private J As Long, P As Long

Private Sub Insert_Data_Click()
    If WSData.Range("C8") = "" Then MsgBox " لا بد من تسجيل رقم المعاملة ": Exit Sub
    kh_Application False
    ReDim Temp(1 To UBound(AR, 1) + 1)
    For J = 0 To UBound(AR)
        Temp(J + 1) = WSData.Range(AR(J))
    Next J
    WSResult.Range("A" & WSResult_LR).Resize(, UBound(Temp, 1)).Value = Temp
    MsgBox " تم ادخال البيانات بنجاح "
    Delete_Data_Click
    kh_Application True
End Sub

Private Sub Delete_Data_Click()
    kh_Application False
    For J = 0 To UBound(AR)
        WSData.Range(AR(J)) = ""
    Next J
    kh_Application True
    MsgBox " تم حذف البيانات بنجاح "
End Sub
Sub kh_Application(ibol As Boolean)
    With Application
        .ScreenUpdating = ibol
        .DisplayAlerts = ibol
        .EnableEvents = ibol
    End With
End Sub
Public Function WSData() As Worksheet
    Set WSData = ThisWorkbook.Worksheets("الرئيسية")
End Function
Public Function WSResult() As Worksheet
    Set WSResult = ThisWorkbook.Worksheets("البيانات")
End Function
Public Function AR() As Variant
    AR = Array("C8", "C10", "C12", "C14", "C16", "C18", "F8", "F10", "F12", "F14", "F16", "F18", "I8", "I10", "I12", "I14", "I16", "I18")
End Function
Public Function WSResult_LR() As Long
    WSResult_LR = Application.Max(1, WSResult.Cells(Rows.Count, 1).End(xlUp).Row) + 1
End Function

برنامج المعاملات المالية.xlsm

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

ارفق ملف اخى للعمل عليه

ويمكنك الاستفاده من

هذا الموضوع

وهذا الموضوع

هذا الموضوع مخالف لقوانين المنتدي

××××××××

يمنع منعا باتا توجيه السؤال إلى شخص بعينه لان هذا قد يدفع الآخرين إلى عدم الإجابة، والهدف هو التفاعل من الجميع.
××××××××
يغلق
××××××××

هذا الموضوع مخالف لقوانين المنتدي

××××××××

انتهاك حقوق الملكيه
××××××××
يغلق
××××××××

هذا الموضوع مخالف لقوانين المنتدي

××××××××

موضوع مكرر
××××××××
يغلق
××××××××

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

ملف جميل وليس به أي مشكله

ما هو المطلوب 

انا لله وإنا إليه راجعون 
خبر محزن للتربية والتعليم بمصر والوطن العربي 

بقلوب مؤمنة بقضاء الله وقدره ننعى إليكم ونعزى أنفسنا فى  
وفاة المبرمج محمد الشابوري ،، صاحب برنامج المنجز 

اللهم أدخله برحمتك فسيح جناتك, اللهم أبدله دارا خير من داره وأهلا خيرا من أهله واجعله مع الصديقين والنبيين والشهداء وحسن أؤلئك رفيقـا -اللهم وسع مدخله وغسله بالماء والبرد.
جعلك الله من أهل الجنة ...إنه على كل شئ قدير و بالإجابة جدير وإنا لله وإنا اليـه راجعـــــــــون   لا حول ولا قوة إلا بالله العلي العظيم
انا لله وانا اليه راجعون 
قال تعالى في كتابه العزيز ( وَلَنَبْلُوَنَّكُمْ بِشَيْءٍ مِنَ الْخَوْفِ وَالْجُوعِ وَنَقْصٍ مِنَ الْأَمْوَالِ وَالْأَنْفُسِ وَالثَّمَرَاتِ وَبَشِّرِ الصَّابِرِينَ * الَّذِينَ إِذَا أَصَابَتْهُمْ مُصِيبَةٌ قَالُوا إِنَّا لِلَّهِ وَإِنَّا إِلَيْهِ رَاجِعُونَ * أُولَئِكَ عَلَيْهِمْ صَلَوَاتٌ مِنْ رَبِّهِمْ وَرَحْمَةٌ وَأُولَئِكَ هُمُ الْمُهْتَدُونَ )