حسونة حسين

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

غير المسار الي اي مسار داخل جهازك ووافنا بالنتائج

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

هل هو نفس الطلب بهذا الرابط ام لا 

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

عدل 

DestPath = ThisWorkbook.Path & "\" & Sh.Range("e11") & ".pdf"

الى

DestPath = "\\10.20.30.3\homedir\a.ghanem\كشف العمليات اليومية\"  & Sh.Range("e11") & ".pdf"

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

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

من فضلك ارفق ملف اخي

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

1- قم بوضع هذا الكود في موديل جديد

2- قم بحفظ الملف بصيغه تقبل الماكرو وليكن XLSB

3- ثم شغل الكود

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet, AR1, AR2, I As Long, J As Long, LR1 As Long, LR2 As Long
    Set WS = ThisWorkbook.Sheets("فواتير العملاء")
    Set SH = ThisWorkbook.Sheets("فاتورة المبيعات")
    AR1 = Array("C3", "C4", "E4", "C5", "C6", "E3", "H3", "J4", "J6")
    AR2 = Array("B", "C", "D", "E", "F", "G", "H", "I", "J")
    LR1 = SH.ListObjects("الجدول4").Range.Columns(2).Cells.Find("*", SearchDirection:=xlPrevious).Row
    LR2 = WS.ListObjects("الجدول2").Range.Columns(1).Cells.Find("*", SearchDirection:=xlPrevious).Row + 1
    
    For I = 8 To LR1
        For J = 1 To 9
            WS.Cells(LR2, J).Value = SH.Range(AR1(J - 1)).Value
        Next J
        For J = 10 To 18
            WS.Cells(LR2, J).Value = SH.Cells(I, AR2(J - 10))
        Next J
        LR2 = LR2 + 1
    Next I

End Sub

تفضل تبسيط للكود

نموذج ادخال بيانات الحجاج داخل الشيت.xlsm

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

ضع متغير باسم الصفحه التي تريد الترحيل لها

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

عذرا لانى اعمل بالموبايل 

Private Sub cmdAdd_Click()
Dim WS As Worksheet SH As Worksheet
Set SH  = ThisWorkbook.Worksheets("Entry")
Set WS = ThisWorkbook.Worksheets(Sh.Range("J4").text)
Dim M As Integer
M = WS.Range("B500").End(xlUp).Row + 1
WS.Cells(M, "B").Value = Sh.Range("G6").Value

2 ساعات مضت, احمد غانم said:

حفظ نسخة من الإيصال نفسه  School Fee Receipt  بصيغة PDF بمسار معين

هذه موجوده في الكود 

انسخ الكود مره اخري

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

عدل 

الفاصلة

,

الى الفاصله المنقوطه

;

لتصبح معادله ابو احمد هكذا

=IF(F8*0.0199<1.99;1.99;IF(F8*0.0199>2.99;2.99;F8*0.0199))

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

تفضل

Option Explicit

Sub Sucess_Fail()
    Dim WSData As Worksheet, WSSucess As Worksheet, WSFail As Worksheet, arr As Variant
    Dim i As Long, J As Long, P As Long, PP As Long, LR As Long, StateRng As Range, State1 As Long, State2 As Long
    
    Set WSData = ThisWorkbook.Worksheets("شيت")
    Set WSSucess = ThisWorkbook.Worksheets("ناجح")
    Set WSFail = ThisWorkbook.Worksheets("دور ثان")
    LR = Application.Max(3, WSData.Cells(Rows.Count, "B").End(xlUp).Row)
    arr = WSData.Range("A3:P" & LR).Value
    Set StateRng = WSData.Range("P2" & ":P" & LR)
    WSSucess.Range("A5:O" & Application.Max(5, WSSucess.Cells(Rows.Count, "B").End(xlUp).Row)).ClearContents
    WSFail.Range("A5:O" & Application.Max(5, WSFail.Cells(Rows.Count, "B").End(xlUp).Row)).ClearContents
    
    State1 = WorksheetFunction.CountIf(StateRng, "ناجح")
    State2 = WorksheetFunction.CountIf(StateRng, "دور ثان")
    P = 1
    PP = 1
    
    ReDim Sucess(1 To State1, 1 To UBound(arr, 2) - 1)
    ReDim Fail(1 To State2, 1 To UBound(arr, 2) - 1)
    
    For i = 1 To UBound(arr, 1)
        For J = 2 To UBound(arr, 2) - 1
            If arr(i, 16) = "ناجح" Then
                Sucess(P, 1) = P
                Sucess(P, J) = arr(i, J)
                If J = 15 Then P = P + 1
            ElseIf arr(i, 16) = "دور ثان" Then
                Fail(PP, 1) = PP
                Fail(PP, J) = arr(i, J)
                If J = 15 Then PP = PP + 1
            End If
        Next J
    Next i
    
    If P > 0 Then WSSucess.Range("A5").Resize(P - 1, UBound(Sucess, 2)).Value = Sucess
    If PP > 0 Then WSFail.Range("A5").Resize(PP - 1, UBound(Fail, 2)).Value = Fail

End Sub

Sucess_Fail.xlsm

جرب هذا التعديل على حسب فهمي

Sub Test()
    Dim Sh As Worksheet, Ws As Worksheet, i As Long, lr As Long, DestPath
    Set Sh = ThisWorkbook.Worksheets("School Fee Receipt")
    Set Ws = ThisWorkbook.Worksheets("Daily Report")
    lr = Application.Max(5, Ws.Cells(Rows.Count, "b").End(xlUp).Row) + 1
    For i = 22 To 15 Step -1
        If Sh.Cells(i, "H") <> 0 Then
            Ws.Range("B" & lr) = Sh.Range("E10")
            Ws.Range("C" & lr) = Sh.Range("E12")
            Ws.Range("D" & lr) = Sh.Range("e11")
            Ws.Range("E" & lr) = Format(Sh.Range("H9"), "[$-1010000]yyyy/mm/dd;@")
            Ws.Range("F" & lr) = Sh.Range("H10")
            Ws.Range("G" & lr) = Sh.Cells(i, "G")
            Ws.Range("H" & lr) = Sh.Cells(i, "H")
            Exit For
        End If
    Next i
    DestPath = ThisWorkbook.Path & "\" & Sh.Range("e11") & ".pdf"
    SH.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DestPath
End Sub

ممكن ملف يوضح النتائج المطلوبه

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

ولو امكن شرح بالصور 

لان المطلوب الى الان غير واضح

السلام عليكم

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

Private Sub TextBox2_Change()
    If TextBox2 = "" Then
        AutoFilterMode = False
    Else
        Ans = MsgBox("هل انتهيت من الكتابه", vbYesNo)
        If Ans = vbYes Then
            Range("H1").AutoFilter , field:=8, Criteria1:=TextBox2.Text
            Dim X
            X = Application.Match(Val(TextBox2), ورقة3.Columns(4), 0)
            If Not IsError(X) Then
                With ورقة3.Cells(X, "B")
                    .Value = ورقة1.Cells(1, "I").Value
                    .Interior.ColorIndex = 30    'From 1 to 56 لون الخلفيه
                    .Font.ColorIndex = 20     'From 1 to 56 لون الخط
                End With
            End If
        End If
    End If
End Sub

ممكن ملف يوضح النتائج المطلوبه

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

تفضل اخي

Option Explicit

Sub Test()
    Dim Sh As Worksheet, Ws As Worksheet, i As Long, lr As Long, DestPath
    Set Sh = ThisWorkbook.Worksheets("School Fee Receipt")
    Set Ws = ThisWorkbook.Worksheets("Daily Report")
    lr = Application.Max(5, Ws.Cells(Rows.Count, "b").End(xlUp).Row) + 1
    For i = 15 To 22
        If Sh.Cells(i, "H") <> 0 Then
            Ws.Range("B" & lr) = Sh.Range("E10")
            Ws.Range("C" & lr) = Sh.Range("E12")
            Ws.Range("D" & lr) = Sh.Range("e11")
            Ws.Range("E" & lr) = Format(Sh.Range("H9"), "[$-1010000]yyyy/mm/dd;@")
            Ws.Range("F" & lr) = Sh.Range("H10")
            Ws.Range("G" & lr) = Sh.Cells(i, "G")
            Ws.Range("H" & lr) = Sh.Cells(i, "H")
            lr = lr + 1
        End If
    Next i
    DestPath = ThisWorkbook.Path & "\" & Sh.Range("e11") & ".pdf"
    Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DestPath
End Sub

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

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

السلام عليكم وبها نبدأ

يرجى شرح ما تريد حتى يتم المساعده

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

تأكد من انه لا يوجد مشكله في اعدادات اللغه العربيه في الجهاز

لان الكود (الرئيسيه) ليس به مشكله 

من منتدى قسم الاكسيل نحيكم🤗

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

هنحتاج نسخه ٦٤ بت كمان علشان السرعه تكون عاليه شويه

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

لا يوجد في الفورم الخاص بك

Me.ComboBox2.Text

عدلها الى

Me.ComboBox1.Text

امين يارب العالمين واياك اخى ايهاب

الحمد لله الذي بنعمته تتم الصالحات

وجزاكم مثله اخى 

الحمد لله الذي بنعمته تتم الصالحات 

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

عدل نطاق المصفوفه من 

Arr = Ws.Range("A2:B" & Ws.Cells(Rows.Count, 1).End(xlUp).Row).Value

الى

Arr = Ws.Range("B2:E" & Ws.Cells(Rows.Count, 2).End(xlUp).Row).Value

وعدل عامود الشروط من العامود الثانى في المصفوفه

Arr(i, 2)

الى العامود الرابع في المصفوفه

Arr(i, 4)

يمكنك رفع ملف اخر

في موضوع جديد

يكون نسخه مصغره من ملفك ببيانات بسيطه 

لكى نفهم المطلوب جيدا

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

تفضل اخى

Private Sub CommandButton1_Click()
    Dim Ws As Worksheet, Arr, dic As Object, Levels, X
    Dim i As Long, R As Long, j As Long, P As Long
    Set Ws = ThisWorkbook.Worksheets("main")
    Arr = Ws.Range("A2:B" & Ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
    Set dic = CreateObject("Scripting.Dictionary")
    R = 1
    Levels = Array(TextBox1, TextBox2, TextBox3)
    Me.ListBox1.Clear
    ReDim B(1 To UBound(Arr, 1))
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        If Not dic.Exists(Arr(i, 1)) Then
            dic.Add Arr(i, 1), R
            B(R) = Arr(i, 1) & "-" & Split(Arr(i, 2))(0)
            R = R + 1
        Else
            B(dic(Arr(i, 1))) = B(dic(Arr(i, 1))) & "-" & Split(Arr(i, 2))(0)
        End If
    Next i
    ReDim Tmp(1 To R - 1)
    For i = LBound(B, 1) To R - 1
        If UBound(Split(B(i), "-")) = UBound(Levels) + 1 Then
            For j = 1 To UBound(Levels) + 1
                X = Application.Match(Split(B(i), "-")(j), Levels, 0)
                If IsError(X) Then GoTo 1
            Next j
            P = P + 1
            Tmp(P) = Split(B(i), "-")(0)
        End If
1   Next i
    If P > 0 Then Me.ListBox1.List = Application.Index(Tmp, Evaluate("row(1:" & P & ")"))
End Sub

test.xlsm