حسونة حسين

جرب هذا التعديل على حسب فهمي 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" Ws.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

وعليكم السلام ورحمه الله وبركاته الكود ليس به مشكله اخى انما المشكله في ادخال البيانات تأكد من ان البيانات ليس بها خطأ #DIV/0! مثل هذه الصورة

ممكن ترفعه على اي موقع رفع وليكن ميديا فاير https://www.mediafire.com/

وعليكم السلام ورحمه الله وبركاته لا يمكن العمل على الصور اخى ارفق الملف الذي به المشكة

بمجرد ما تكتب رقم 4 يتم الترحيل الى شيت الارصدة عند رقم 4 في خليه b7 (دي تمام الكود فعلا يقوم بهذا ) متي تريد ان يرحل الكود الى الملف الجديد المسمى (الارصدة.xlsx) ؟ واين يرحل الكود في الملف الجديد المسمى (الارصدة.xlsx) ؟ اين يوجد التاريخ ؟ (ثم لو ضغطت على رقم 4 سوف يرحل الى ملف الارصده) ولكن لو ضغطت مره اخري على رقم 5 ما المفروض ان يفعله الكود ؟ لانه لا يوجد شرح كافي لفهم المطلوب اخى

وعليكم السلام ورحمة الله وبركاته ضع هذه المعادله في الخليه C6 ثم اسحب يسارا ونزولا لاسفل مثال.xlsx

ارفق صورة لمحرر الاكواد تظهر فيها اسماء الموديلات وارفق ملف به المشكله

وعليكم السلام ورحمه الله وبركاته بعد اذن اخى على عدل Dim Start_date As date, Last_date As date الى Dim Start_date As Double, Last_date As Double ووافنا بالنتيجه

الشكر لله اخي

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

المعادله اخى موجوده في الملف المرفق في المشاركه السابقه لي