أبو حنــــين

الكود يصبح بهذا الشكل Sub tarhil() If Cells(9, 1).Value = "" Then Exit Sub With Application .ScreenUpdating = False Range(Cells(9, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)).Copy _ Sheet2.Range("A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1) '___________________________ Range("A5:E5").Copy Sheet3.Range("A" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row + 1) Sheet3.Range("F" & Sheet3.Cells(Rows.Count, 5).End(xlUp).Row).Value = _ Range("E" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Value .CutCopyMode = False: .ScreenUpdating = True End With End Sub

لترحيل القيم فقط Sub tarhil() If Cells(9, 1).Value = "" Then Exit Sub With Application .ScreenUpdating = False Range(Cells(9, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)).Copy Sheet2.Range("F" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlPasteValues R1 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1 R2 = Sheet2.Cells(Rows.Count, 6).End(xlUp).Row Range("A5:E5").Copy Sheet2.Range("A" & R1 & ":E" & R2).PasteSpecial xlPasteValues .CutCopyMode = False: .ScreenUpdating = True End With End Sub حيث استعملنا PasteSpecial xlPasteValues

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

مرحبا هذا كود حاص بالترحيل Sub tarhil() If Cells(9, 1).Value = "" Then Exit Sub With Application .ScreenUpdating = False Range(Cells(9, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5)).Copy _ Sheet2.Range("F" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1) R1 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1 R2 = Sheet2.Cells(Rows.Count, 6).End(xlUp).Row Range("A5:E5").Copy Sheet2.Range("A" & R1 & ":E" & R2) .CutCopyMode = False: .ScreenUpdating = True End With End Sub

الأخ طلعت محمد جزاك الله خيرا

السلام عليكم جميعا عرض مغري و محدود من تاريخ 2100/01/01 الى 2199/12/31 و الكمية محدودة و الرجاء من الزبائن عدم التدافع و احترام الطابور . الكل حياخد نصيبو . ****************************************** تم استدارك الخطأ و استرجاع الاموال الضائعة من المصيبة الى فاتت مع بحث و تعديل فاتورة ارجو التجربة لاستدراك الاخطاء 5-فاتورة.rar

مرحبا انظر الرابط https://www.officena.net/ib/topic/56808-نموذج-سريع-للبحث-في-القرآن-الكريم-بدون-تشكيل-كلمة-البحث/#comment-360382

السلام عليكم هذا العمل يتطلب كبداية ملف اكسل يحتوي على القرآن الكريم كاملا و من مصدر موثوق

مرحبا للأسف حاولت لكنني لم استطع بسبب الخلايا المدمجة في الملفات

مرحبا لو ارسلت مثالا للملف الخاص بالجمع و بعض الملفات ( 3 او 4 ) التي تريد الاستيراد منها و اكتب فيها بعض البيانات الوهمية محددا الاعمدة التي تريد استيرادها و مكان لصقها في الملف الاول

السلام عليكم تم عمل المطلوب 4-فاتورة.rar

السلام عليكم ربما يكون بهذه الطريقة في غياب ملف مرفق Sub calcule() Dim sh As Worksheet, C As Range, x As Integer x = 0 For Each sh In Sheets For Each C In sh.Range("F1:F" & sh.Cells(Rows.Count, 6).End(xlUp).Row) If C.Value = Range("A1").Value Then x = x + 1 Next Next MsgBox x End Sub

السلام عليكم تكتب في الخلية الهدف المعادلة التالية ثم تقوم بسحبها الى الاسفل = A2 & " - " & B2 حيث الاشارة ( & ) تشبه علامة + لكنها لا تقوم بالجمع بل تضم جملة الى أخرى او رقم الى آخر مثال 1 & 1= 11 الاسم & اللقب = الاسم اللقب

السلام عليكم تم عمل المطلوب ان شاء الله و تبقى التجربة هي السبيل الوحيد لاكتشاف الاخطاء 3-فاتورة.rar

السلام عليكم تم عمل المطلوب مع إضافة خاصية حفظ الفاتورة الحالية تحسبا لاستدعائها او تعديلها ربما الملف يحتوي على اخطاء لانني جربته لمرتين او ثلاث مرات فقط ان كانت هناك اخطاء سنستدركها حالة اكتشافها بالنسبة لطريقة الدفع يمكن تحولها الى قائمة منسدلة او بالطريقة المدرجة مع الملف 2-فاتورة.rar

السلام عليكم أخي الزباري جزاكم الله خيرا في انتظار السؤال الموالي . . . .

و عليكم السلام أخي انسخ الكود كما هو و ألصقه في ورقة العمل و لا تنسي ان تغير إسم الفورم KH_T_SEARSH حسب الفورم التي أنشأتها

الكود يصبح بهذا الشكل Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Union(Range("A2:A20000"), Range("F2:F20000"))) Is Nothing Then Cancel = True KH_T_SEARSH.Show End If End Sub هناك جزئية ناقصة و هذا التصحيح If Not Intersect(Target, Union(Range("A2:A20000"), Range("F2:F20000"), Range("J2:J20000"))) Is Nothing Then

مرحبا تم عمل المطلوب 1-فاتورة.rar

السلام عليكم الملف بعد التعديل مع اضافة مسح للبيانات فاتورة.rar

الإجابة عن السؤال الأول Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim Last As Integer, Qn As String If Target.Column = 8 And Target.Row > 3 And Target <> "" Then Cancel = True Last = Cells(Rows.Count, 1).End(xlUp).Row + 1 Qn = InputBox("أدخل الكمية", "الكمية") If Not IsNumeric(Qn) Then Exit Sub With Cells(Last, 1) .Value = Last - 8: .Offset(, 1).Value = Target.Offset(, 1).Value .Offset(, 2).Value = Val(Qn): .Offset(, 3).Value = Target.Offset(, 2).Value .Offset(, 4).Value = Val(Qn) * Target.Offset(, 2).Value: .Offset(1, 3).Value = "ÇáÅÌãÇáí" .Offset(1, 4).Value = WorksheetFunction.Sum(Range("E9:E" & Last )) End With With Range(Cells(Last, 1), Cells(Last, 5)) .Borders.Value = 1: .Borders.ColorIndex = 48 End With End If End Sub

Private Sub CommandButton3_Click() Sheets("pro1").Select Sheets("pro1").Copy Before:=Sheets(1) End Sub إحتمال الخطأ الموجود في هذا الكود هو : - 1 لا توجد ورقة بإسم pro1 - 2 خطأ في كتابة الاسم كإضافة او نقصان مسافة ( حيث المسافة لا يمكن أن ترى بالعين )

السلام عليكم جرب المرفق شتوية 2017.rar

السلام عليكم جرب المرفق شتوية 2017.rar

السلام عليكم جرب المرفق Book1.rar