أبو حنــــين

السلام عليكم اخي الحبيب ابو عبد الرحمان عندما لاحظت صورة البروفيل الخاصة بك ( العين البني ) ، و الصورة الخاصة بي ( خديجة ) و كأنني اقول بلسان الحال : قاعد يبص فيا و انا حاطط إيدي على خدي فجات ببالي الاغنية ألي بتقول : بتنهد وايدي على خدي من قلب ربّاني وطلع قديلا انا فهمان شو بده ولا حضرته فهمان شو بدي لكنني فهت انك تريد التعديل على الكود اسعد الله ايامك و تقبل الله منا و منكم صالح الاعمال ، و الله ليك وحشة Sub officena() Dim Last As Long, R As Long, LR As Long Last = Sheet4.Cells(Rows.Count, "A").End(xlUp).Row Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Sheet4 For R = 5 To Last If WorksheetFunction.CountIf(.Range("A8:A" & Last), CStr(.Cells(R, "a"))) > 1 Then LR = Sheet7.Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(R, "A").Resize(1, 7).Copy Sheet7.Cells(LR, "A") End If Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

السلام عليكم جرب المرفق ضمان (تم الحفظ 2تلقائياً).rar

Sub copyto() Dim lr As Integer, sh As Worksheet Set sh = Sheets("10") With sh If Selection.Count < 16 Then MsgBox "التحديد غير صحيح", vbExclamation, "خطأ" Exit Sub Else lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Selection.Copy sh.Range("A" & lr).PasteSpecial (xlPasteValues) End If End With Application.CutCopyMode = False End Sub هذه الجزئية يمكن الاستغناء عنها MsgBox "التحديد غير صحيح", vbExclamation, "خطأ"

Sub copyto() Dim lr As Integer, sh As Worksheet Set sh = Sheets("10") With sh If Selection.Count < 16 Then MsgBox "التحديد غير صحيح", vbExclamation, "خطأ" Exit Sub Else lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Selection.Copy sh.Range("A" & lr).PasteSpecial (xlPasteValues) End If End With Application.CutCopyMode = False End Sub

مرحبا استعمل هذا الكود Sub copyto() Dim lr As Integer, sh As Worksheet Set sh = Sheets("10") With sh If Selection.Count < 16 Then MsgBox "التحديد غير صحيح", vbExclamation, "خطأ" Exit Sub Else lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Selection.Copy sh.Range("A" & lr).PasteSpecial (xlPasteValues) End If End With Application.CutCopyMode = False End Sub

مرحبا جرب هذا الكود Sub aaaa() Dim c As Range For Each c In Range("A2:A100") If c.Value < 0 Then c = 0 Next End Sub

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

مرحبا جرب هذا الكود Sub ssCOPY() Dim sh As Worksheet, sh1 As Worksheet, x As Integer, i As Integer Set sh = Sheets("البيانات") Set sh1 = Sheets("الضمانات المنتهية ") '--------------------------------------------------------- x = 4 Application.ScreenUpdating = False With sh Last = .Cells(Rows.Count, "A").End(xlUp).Row For i = 5 To Last If .Cells(i, 4).Interior.ColorIndex = 2 Then .Cells(i, 4).Resize(, 13).Copy sh1.Range("A" & x).PasteSpecial xlPasteValues x=x+1 End If Next End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

الحمد لله

ربما هناك دمج في الخلايا

تأكد من كتابة اسم الشيت Report

غير الكود السابق بهذا الكود Sub Maint_click() Sheets("Maint").Range("B5:H16").Copy Sheets("Report").Range("B69").PasteSpecial (xlPasteValues) End Sub

مرحبا الشرح في المرفق P&LL_test.rar و هذا المثال في حالة تشغيل الكود من ورقة أخرى P&LL_test 2.rar

جرب هذه الطريقة في ورقة العمل انسخ هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Not Target.Column = 1 Then Exit Sub If Not IsEmpty(Target) = True And Target.Offset(, 10) = "" Then Range(Target.Offset(-1, 10), Target.Offset(-1, 21)).Copy Range(Target.Offset(, 10), Target.Offset(, 21)).PasteSpecial xlPasteAll End If Application.CutCopyMode = False End Sub

هناك طريقتان للاستعمال الورقة استعمال الخاصية Name يؤثر على اعادة تسمية الورقة اما استعمال الخاصية CodeName فلا يؤثر على اعادة التسمية و كمثال بسيط : افتح ملف اكسيل و ضع زر و اكتب فيه الكود التالي و لاحظ الفرق عندما تغير اسم الورقة Sub ShowNane() MsgBox ActiveSheet.Name MsgBox ActiveSheet.CodeName End Sub

مرحبا في الكود الذي يبدأ بالسطر : Private Sub kh_AddNewRecord() أكتب في آخر الكود الأسطر التالية With Me.Controls("Textdt" & 7) .Value = Format(Date, "dd-mm-yyyy") .Enabled = False End With

السلام عليكم في آخر كود SAMA_1 ضف هذا السطر : If Not WARED.Cells(Mh, 13) = "" Then CheckBox2.Value = True Else CheckBox2.Value = False

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

مرحبا استعمل هاتين الدالتيين ' =SUMIF(D2:D7;"شبكة";C2:C7) ' =SUMIF(D2:D7;"نقدي";C2:C7)

السلام عليكم يمكن ان تستعمل الكود التالي Sub N_Year() For x = 4 To 369 Range("A" & x) = Replace(CStr(Range("A" & x)), Year(Range("A" & x)), Range("A2"), 1, , vbTextCompare) Range("A" & x) = Format(Range("A" & x), "dd-mm-yyyy") Next End Sub

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

هل بهذه الطريقة test2.rar

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

هذه محاولة تشبه الشكل نوعا ما مثال2.rar

السلام عليكم هذا كود أخي ياسر العربي لكن في حدث قبل الطباعة 1طباعة.rar