أبو حنــــين

رمضان مبارك اعتقد ان هذا هو المطلوب الفرز.rar

بدون اي معادلات اجعل تنسيق الخلية مخصص : mmm

يمكنك كتابة الكود التالي Private Sub Workbook_Open() With ورقة1 .Range("C1") = Month(Now) .Range("B1") = Day(Now) .Range("A1") = Format(Day(Now), "ddd") .Range("D1") = Year(Now) End With End Sub

السلام عليكم أو اكتب التالي Private Sub Workbook_Open() ورقة1.Range("A1") = Date End Sub

السلام عليكم على افتراض ان العمود الذي يحتوي على الاسماء هو العمود A ضع هذا الكود : Private Sub Worksheet_SelectionChange(ByVal Target As Range) For Each cel In [A1:A1000] If Application.WorksheetFunction.CountIf(Range("A1:A1000"), cel) > 1 Then cel.Interior.ColorIndex = 4 Else cel.Interior.ColorIndex = 0 End If Next End Sub

غير هذا الكود : Private Sub CommandButton2_Click() Dim Endrow As Integer With Sheet1 Endrow = .Range("A" & .Rows.Count).End(xlUp).Row TextBox1.Value = Endrow End With TextBox2.SetFocus End Sub بالكود التالي : Private Sub CommandButton2_Click() Dim Endrow As Integer With Sheet1 Endrow = Sheet1.Range("A" & .Rows.Count).End(xlUp).Row TextBox1.Value = Sheet1.Range("A" & .Rows.Count).End(xlUp).Value End With TextBox2.SetFocus End Sub

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

السلام عليكم 1.rar

السلام عليكم هل تقصد هكذا tes.rar

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

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

برنامج ممتاز لكن مصدره محمي بكلمة مرور ، و هذا يجعل فائدته محدودة و الاستفادة منه غير ممكنة على كل حال مشكور أخي على الجهد

جرب المرفق 1.rar

آخر خلية تحتوي على قيمة Sheet1.Range("A" & .Rows.Count).End(xlUp).Row - 1

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

ارجو التوضيح من اين يكون القص و اين يكون اللصق

التصحيح مجلد جديد.rar

وقع سهوا خطأ في الكود السطر : If Dir(ThisWorkbook.Path & "\2.xls") <> "" Then يعوض بالسطر التالي If Dir(ThisWorkbook.Path & "\" & Range("B1") & ".xls") <> "" Then

أو ان أردت مثال آخر ، افتح الملف المسمى رقم 1 أكتب في الخلية B2 اسم الملف اكتب في الخلية B3 الخلية التي تريد اللصق فيها تم حدد الصفوف التي تريد قصها ثم اضغط على قص البيانات المرفق يحتوي على ملفين في مجلد واحد افتح الملف المسمى 1 فقط مجلد جديد.rar

هذا مجرد مثال يمكن تطويره حسب رغبتك ان اردت ' الشرط الأول ان الملفين يجب ان يكونا في نفس المجلد ' الشرط الثاني هو ان الملف الذي تريد اللصق فيه اسمه 2 أي رقم 2 ' يمكن تغيير ذلك حسب رغبتك Private Sub CommandButton1_Click() If Dir(ThisWorkbook.Path & "\2.xls") <> "" Then Selection.Cut Workbooks.Open (ThisWorkbook.Path & "\2.xls") ActiveSheet.Range("A1").Select ActiveSheet.Paste Application.CutCopyMode = False Else 1 MsgBox "الملف غير موجود", vbInformation, "خطأ" Application.CutCopyMode = False End If End Sub

جراك الله خيرا اخي بن علية على هذه الملاحظة

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

حسب علمي و الله اعلم ان : Selection.EntireRow.Delete Shift:=xlUp Selection.EntireRow.Delete Selection.Delete كلها تقوم بحذف الصف المحدد و الله اعلم

تفضل اخي Private Sub CommandButton1_Click() On Error GoTo 1 Dim ms As String RP = MsgBox(" [font=arial,helvetica,sans-serif]ÃäÊ Úáì æÔß ÍÐÝ ÕÝ ßÇãá[/font] ", vbCritical + vbMsgBoxRight + vbYesNo, "ÊÍÐíÑ") If RP = vbNo Then Exit Sub Else Selection.Delete Shift:=xlUp End If 1 End Sub

'الغاء التجميد ActiveWindow.FreezePanes = False ' تجميد الالواح ActiveWindow.FreezePanes = True