احمدزمان

السلام عليكم و رحمة الله وبركاته بعد اذن استاذنا ياسر خليل مرفق الكود Sub trhil_to_sheet() Dim FS As Worksheet, TS As Worksheet Dim FR, TR, ER1, ER2 Dim TSN Set FS = Sheets("transe") FS.Unprotect For FR = 3 To FS.UsedRange.Rows.Count TSN = FS.Cells(FR, 1).Text If TSN = "" Then GoTo 9 For TS1 = 1 To Sheets.Count If Sheets(TS1).Name = TSN Then Set TS = Sheets(TSN) TR = TS.Range("B9999").End(xlUp).Row + 1 If TR < 20 Then TR = 20 TS.Unprotect FS.Range("B" & FR & ":C" & FR).Copy TS.Range("B" & TR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False FS.Range("E" & FR & ":G" & FR).Copy TS.Range("E" & TR).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False FS.Range("B" & FR & ":C" & FR & ",E" & FR & ":G" & FR).ClearContents GoTo 9 End If Next TS1 9 Next FR ActiveWorkbook.Save End Sub

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

وعليكم السلام احذف الجزء .TEXT او جرب الملف التالي الذي تم تعديله نموزج فاتورة.rar

السلام عليكم و رحمة الله وصلنا للخطوة الأخيرة مسح الفاتورة لحذف الفاتورة يجب جلب بياناتها اولا اضغط جلب فاتورة وادخل الرقم بعد جلب الفاتورة اضغط حذف يتم حذف بيانات الفاتورة Sub invoice_Kill() ' ÍÐÝ ÈíÇäÇÊ ÝÇÊæÑÉ Application.ScreenUpdating = False Set WS = Worksheets("INVOICE") Set WS1 = Worksheets("mat") LR1 = WS1.Range("c55555").End(xlUp).Row + 1 If WS.Range("J3") = "" Then GoTo 6 For FR = 10 To 50 LR1 = Val(WS.Cells(FR, 12)) If WS.Cells(FR, 12) = "" Then GoTo 7 WS1.Range("D" & LR1 & ":L" & LR1).ClearContents LR1 = LR1 + 1 7 Next FR Application.CutCopyMode = False WS.Select Application.ScreenUpdating = True 6 MsgBox "Êã ÍÐÝ ÈíÇäÇÊ ÇáÝÇÊæÑÉ THIS BILL DELETED" Application.Run "invoice_cleer" Range("E3").Select End Sub اضفنا بعض التنسيقات للورقة و اصبح جاهز للإستخدام نموزج فاتورة.rar

السلام عليكم و رحمة الله و بركاته اضفنا زر لتعديل بيانات الفاتورة بعد جلب بيات الفاتورة قم بتعديل ماتريد و امسح من الفاتورة الأصناف التي تريد مسحها ثم اضغط علة تعديل يتم تعديل البيانات مع الخزاص السابقة لأضافة فاتورة من ترحيل ثم طباعة ثم مسح بيانات الفاتورة Sub trhill_Tadeel() 'ÊÑÍíá ÇáÝæÇÊíÑ ÇáãÚÏáå Application.ScreenUpdating = False Set WS = Worksheets("INVOICE") Set WS1 = Worksheets("mat") LR1 = WS1.Range("c55555").End(xlUp).Row + 1 If WS.Range("J3") = "" Then GoTo 6 For FR = 10 To 50 LR1 = Val(WS.Cells(FR, 12)) If WS.Cells(FR, 12) = "" Then GoTo 7 WS1.Cells(LR1, 2) = WS.Range("E3").Value WS1.Cells(LR1, 3) = WS.Range("I3").Value WS1.Cells(LR1, 4) = WS.Range("E5").Value WS1.Cells(LR1, 12) = WS.Range("E7").Value WS.Range("D" & FR & ":J" & FR).Copy WS1.Range("E" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False LR1 = LR1 + 1 7 Next FR Application.CutCopyMode = False WS.Select Application.ScreenUpdating = True 2 Range("A1:K53").PrintOut Copies:=1 Q1 = MsgBox("Êã ÍÝÙ ÈíÇäÇÊ ÇáÝÇÊæÑÉ æ ÌÇÑí ØÈÇÚÉ ÇáÝÇÊæÑÉ - åá ÊÑíÏ ØÈÇÚÉ äÓÎ ÇÎÑì", vbYesNo, "ØÈÇÚÉ") If Q1 = vbYes Then GoTo 2 6 Application.Run "invoice_cleer" Range("E3").Select End Sub

السلام عليكم ورحمة الله وبركاته اضفنا زر لمسح بيانات الفاتورة الحالية Sub invoice_cleer() 'مسح كامل بيانات الفاتورة و اضافة رقم فاتورة Sheets("invoice").Select Sheets("invoice").Unprotect Range("E3,J3,E5,E7,D10:H49,J10:J49,L10:L49").ClearContents Range("E3").FormulaR1C1 = "=NOW()" Range("F3").FormulaR1C1 = "=R3C5" ActiveSheet.PageSetup.PrintArea = "$B$2:$K$53" ActiveWindow.View = xlPageBreakPreview ActiveWindow.Zoom = 113 ActiveWindow.DisplayHeadings = False ActiveWindow.DisplayGridlines = False ActiveWindow.LargeScroll Down:=-99 ActiveWindow.LargeScroll ToRight:=99 Range("I3") = Range("L3") Range("E5").Select End Sub و اضفنا صورة الطباعة و الذي يعمل به الكود السابق من ترحيل زطباعة و مسح ثم اضفنا زر جلب البيانات لأي فاتورة بالضغط علية يظهر مربع نص تدخل به رقم الفاتورة المطلوبة ثم موافق يتم اظهار بيانات الفاتورة المطلوبة مع كتابة COPY بجوار رقم الفاتورة Sub GET_INV_NO() 'جلب بيانات الفاتوورة بالرقم Q1 = InputBox("INPUT BOLL No أدخل رقمالفاتورة المطلوبة", "جلب") Q1 = Val(Q1) Set WS = Worksheets("INVOICE") Set WS1 = Worksheets("mat") WS.Select WS.Range("E3,E5,E7,D10:H49,J10:J49,L10:L49").ClearContents WS.Range("J3").Text = "نسخة Copy" WS.Unprotect LR1 = WS1.Range("c55555").End(xlUp).Row + 1 TR = 10 For FR = 4 To LR1 If WS1.Cells(FR, 3) = Q1 Then WS.Range("E3") = WS1.Cells(FR, 2).Value WS.Range("I3") = WS1.Cells(FR, 3).Value WS.Range("E5") = WS1.Cells(FR, 4).Value WS.Range("E7") = WS1.Cells(FR, 12).Value WS1.Range("E" & FR & ":K" & FR).Copy WS.Range("D" & TR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS.Range("L" & TR) = FR TR = TR + 1 End If Next FR End Sub

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

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

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

السلام عليكم و رحمة الله جرب المرفق حسب فهمي و الله اعلم اسماء الحسابات_4.rar

السلام عليكم و رحمة الله وبركاته اخي الفاضل استفدنا من الكود الموجود وقمنا بعمل كود يقوم بـ4خطوات بضغطة واحدة ترحيل الفاتورة طباعة الفاتورة بعد الترحيل مسح الفاتورة زيادة رقم 1 لرقم الفاتورة بعد المسح Sub trhil_invoice() Application.ScreenUpdating = False Dim LR As Long, LR1 As Long Dim WS As Worksheet Dim WS1 As Worksheet Set WS = Worksheets("INVOICE") Set WS1 = Worksheets("mat") LR1 = WS1.Range("c55555").End(xlUp).Row + 1 Dim FR For r = 6 To LR1 If WS1.Cells(r, 3) = WS.Range("I3") Then MsgBox "This invoice already exist, No shift will done": Exit Sub Next For FR = 10 To 50 If WS.Cells(FR, 3) = "" Then GoTo 7 WS1.Cells(LR1, 2) = WS.Range("E3").Value WS1.Cells(LR1, 3) = WS.Range("I3").Value WS1.Cells(LR1, 4) = WS.Range("E5").Value WS1.Cells(LR1, 12) = WS.Range("E7").Value WS.Range("D" & FR & ":J" & FR).Copy WS1.Range("E" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False LR1 = LR1 + 1 7 Next FR Application.CutCopyMode = False WS.Select Application.ScreenUpdating = True 2 Range("A1:K53").PrintOut Copies:=1 Q1 = MsgBox("Êã ÍÝÙ ÈíÇäÇÊ ÇáÝÇÊæÑÉ æ ÌÇÑí ØÈÇÚÉ ÇáÝÇÊæÑÉ - åá ÊÑíÏ ØÈÇÚÉ äÓÎ ÇÎÑì", vbYesNo, "ØÈÇÚÉ") If Q1 = vbYes Then GoTo 2 Range("E3,E5,E7,D10:H49,J10:J49").ClearContents Range("E3").Select ActiveWindow.SmallScroll Down:=-45 Range("I3") = Range("I3") + 1 End Sub آمل ان يكون به المطلوب نموزج فاتورة.rar

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

السلام عليكم و رحمة الله وبركاته اخي الكريم مرحبا بك بين اخوانك وحيث ان هذه اول مشاركة لك اود ان اوضح لك نقطة حول الموضوع

السلام عليكم و رحمة الله وبركاته جزاك الله كل خير اخي ياسر رااااااااااااائع جدا كــ عادتك

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

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

الحمد لله هذا من فضل ربي و اي استفسار حاضرين

السلام عليكم و رحمة الله وبركاته بعد الشكر الجزيل لأخينا علي المصري جزاه الله خيرا على التوضيح ========= قمت بالتجربة التالية ونجحت الحمد لله بدون اظهار الشيت و الغاء الحماية قمنا بالغاء حماية الخلايا للملفات 1 الى 4 من تنسيق خلايا - حماية - تم تأمينها ثم اضفنا السطر التالي للكود Sheets("maindata").Range("aa1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False و الحمد لله نجحت العملية كما في المرفق AYMZتعديل1.rar

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

جزاك الله خيرا

و عليكم السلام الآن الطلب واضح جزاك الله خيرا راجعت الملف و ان شاء الله ممكن وسوف احتاج الى اضافة للكود بعض التعريفات لسهولة الوصول غدا ان شاء الله

السلام عليكم فكرة جميلة وشرح واضح جزاك الله خيرا

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

السلام عليكم اخي الكينق لايوجد ملف 0 في المجلد يوجد ملف Student وهذا الملف لايوجد به ورقة Maindata ولا يوجد به ورقة مخفية

السلام عليكم اخي الفاضل تم تغيير الكود و اضطررنا الى الغاء دمج الخلايا للعناوين جرب المرفق المخزن تجربة.rar