محمد هشام.

تم التعديل في الملف المرفق في المشاركة رقم 1 واليك كود اخر يمكنك التعديل عليه ليتوافق مع ملفك الاصلي Sub copy_columns_paste() Dim lr As Integer, MH As Integer, sh1 As Worksheet, sh2 As Worksheet, i As Long Sheet2.Activate 'افراغ البيانات القديمة Range("d10", Range("F" & Rows.Count).End(4)).ClearContents Range("L10", Range("L" & Rows.Count).End(4)).ClearContents Range("N10", Range("N" & Rows.Count).End(4)).ClearContents Set sh1 = Sheet1 Set sh2 = Sheet2 lr = sh1.Cells(Rows.Count, 4).End(xlUp).Row For i = 10 To lr ' تحديد صف بداية النسخ MH = sh2.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row 'العمود المراد ترحيله من شيت 1 _____ العمود المرحل اليه في شيت 2 sh2.Cells(MH, 4) = sh1.Cells(i, 4) sh2.Cells(MH, 5) = sh1.Cells(i, 5) sh2.Cells(MH, 6) = sh1.Cells(i, 6) sh2.Cells(MH, 12) = sh1.Cells(i, 9) sh2.Cells(MH, 14) = sh1.Cells(i, 12) Next i End Sub

تم تعديل الملف بداخله شرح مبسط @2saad

وغليكم السلام ورحمة الله تعالى وبركاته تفضل استاد سغد Sub Test() Dim lr As Long Application.ScreenUpdating = False With Sheet1 lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row .Range(.Cells(10, "D"), .Cells(lr, "F")).Copy Sheet2.Cells(10, "D") .Range(.Cells(10, "I"), .Cells(lr, "I")).Copy Sheet2.Cells(10, "L") .Range(.Cells(10, "L"), .Cells(lr, "L")).Copy Sheet2.Cells(10, "N") End With Application.ScreenUpdating = True End Sub W_S.xlsm

تفضل اخي Sheet_name.xlsb

السلام عليكم ورحمة الله تعالى وبركاته استاد فوزي لم استوعب طلبك حتى رايت حلول الاساتدة جزاهم الله خيرا بعد ادن الاساتده طبعا اليك حل اخر توزيع الايام مع الشهور4.xlsm

اخي لقد تمت الاجابة عن طلبك من قبل الاساتدة اليك حل اخر ربما هدا طلبك Dim Last As Long Last = Worksheets(Mydate).UsedRange.Rows.Count Worksheets(Mydate).Range("A1:f" & Last).AdvancedFilter xlFilterCopy _ , Worksheets(MyFind).Range("K2:L3"), Worksheets(MyFind).Range("A5:f5"), False Dim lr1 As Long lr1 = Sheet2.Range("G" & Rows.Count).End(xlUp).Row + 1 Range("G6:G" & lr1).Clear lr2 = Cells(Rows.Count, "E").End(xlUp).Row + 1 For i = 6 To lr2 If Cells(i, "F") = "" Then Cells(i, "F").Offset(-1, 1).Select ActiveCell = Evaluate("SUM(d6:d" & lr2 & "*E6:E" & lr2 & ")") Exit For End If Next End Sub OFFICENA 2024.xlsm

بعني انت الدي وضعت هدا الكود Private Sub TextBox1_Change() If Sheet1.TextBox1.Value <> "" Then Sheet1.ListBox1.Visible = True Else Sheet1.ListBox1.Visible = False End If End Sub

تفضل اخي قد تم تعديل كود الطباعة في الملف المرفق للتجربة ليتم تنسيق حجم الفواتير تلقائيا A4 فاتورة_Mh5-user form.xlsm

قم بتصميم userform كما تشاء وسوف نحاول ننفذ المطلوب باذن الله تعالى. تفضل اخي تم اضافة كود لافراغ شيت المطبوعات ضروري سوف تحتاجه في آخر اليوم بعد الإنتهاء من طباعة الفواتير فاتورة_Mh4 - .xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اين هي listbox

تفضل اخي تمت اضافة صف بين كل فاتورة فاتورة_Mh4 - .xlsm

اسف اخي على التاخير ودالك بسبب ظروف العمل تفضل اخي لاكن ركز معي جيدا الفكرة انه تم تصميم نمودج للفاتورة في شيت مخفي يتم نسخ البيانات من الفاتورة اليه ثم اعادة نسخه الى شيت المطبوعات لاجراء اللمسات الاخيرة . يعني عند الرغبة في تعديل شكل الفاتورة لابد من التعديل على الاصل وهو شيت مخفي باسم .(invoice) تم انشاء كودين الاول لطباعة الفاتورة الحالية او استدعاء فاتورة قديمة مثلا وطباعتها ودالك بانشاء شيت جديد باسم فاتورة جاهز للطباعة . يتم حدفه تلقائيا عند اعادة تشغيل الملف مرة اخرى او الرغبة في نسخ فاتورة اخرى يتم حدفه وتعويضه بالفاتورة الجديدة اما بالنسبة لطلبك الاخير فقد تم تعديل كود الترحيل حيث يتم ترحيل البيانات الى شيت اليومية مع نسخ الفواتير تلقائيا في شيت المطبوعات تحت بعض بدون فراغات . وبنفس الفكرة اسف على الاطالة لاكن للتوضيح فقط . اليك الاكواد Sub invoice_printer2() 'هدا الكود لانشاء ورقة جديدة ونسخ الفاتورة Dim ws As Worksheet Dim r As Range Dim MH As Long, MH1 As Long Dim rng As Range Dim i As Integer, counter As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Sheet In ActiveWorkbook.Worksheets If Sheet.Name = "الفاتورة" Then Sheet.delete End If Next Sheet Worksheets("invoice").Visible = True Worksheets("invoice").Copy after:=Worksheets("invoice") ActiveSheet.Name = "الفاتورة" With ActiveSheet MH1 = .Cells(.Rows.Count, "E").End(xlUp).Row - 1 End With Range("b7:E" & MH1).ClearContents Range("c1:c5").ClearContents Set ws = Sheets("الفاتورة") Sheet1.Activate MH = Range("C" & Rows.Count).End(3).Row Range("F9:F" & MH).Copy ws.Range("B7") Range("C9:C" & MH).Copy ws.Range("C7") Range("D9:D" & MH).Copy ws.Range("D7") Range("G9:G" & MH).Copy ws.Range("E7") ws.Range("C2").Value = Range("B3").Value ws.Range("C4").Value = Range("B5").Value ws.Range("C5").Value = Range("B6").Value ws.Range("C1").Value = Range("D6").Value ws.Range("c3").Value = Range("F5").Value Set rng = ws.Range("E7:E30") i = 1 For counter = 1 To rng.Rows.Count If rng.Cells(i) = "" Then rng.Cells(i).EntireRow.delete Else i = i + 1 End If Next Worksheets("invoice").Visible = False Application.ScreenUpdating = True Application.DisplayAlerts = True Sheets("الفاتورة").Activate الكود الثاني والمهم Sub invoice_printer() 'ترحيل الفواتير لشيت المطبوعات تلقائيا عند كل ترحيل Dim ws As Worksheet Dim r As Range Dim MH As Long, MH1 As Long Dim rng As Range Dim i As Integer, counter As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False Worksheets("invoice").Visible = True Set ws = Sheets("invoice") Sheet1.Activate MH = Range("C" & Rows.Count).End(3).Row Range("F9:F" & MH).Copy ws.Range("B7") Range("C9:C" & MH).Copy ws.Range("C7") Range("D9:D" & MH).Copy ws.Range("D7") Range("G9:G" & MH).Copy ws.Range("E7") ws.Range("C2").Value = Range("B3").Value ws.Range("C4").Value = Range("B5").Value ws.Range("C5").Value = Range("B6").Value ws.Range("C1").Value = Range("D6").Value ws.Range("c3").Value = Range("F5").Value derlig = Sheets("الفواتير المطبوعة").Range("a" & Rows.Count).End(xlUp).Row + 1 Worksheets("invoice").Range("A1:E30").Copy Worksheets("الفواتير المطبوعة").Range("a" & derlig) Sheet8.Activate MH2 = ActiveSheet.Range("C" & Rows.Count).End(3).Row For Each c In Range("A1:A5") If c = "" Then c.EntireRow.delete Next Set rng = Sheets("الفواتير المطبوعة").Range("c7:c" & MH2) i = 1 For counter = 1 To rng.Rows.Count If rng.Cells(i) = "" Then rng.Cells(i).EntireRow.delete Else i = i + 1 End If Next Sheet7.Activate With ActiveSheet MH1 = .Cells(.Rows.Count, "E").End(xlUp).Row - 1 End With Range("b7:E" & MH1).ClearContents Range("c1:c5").ClearContents Worksheets("invoice").Visible = False Application.ScreenUpdating = True Application.DisplayAlerts = True Sheets("مستند قيد").Activate End Sub بالتوفيق فاتورة_Mh3 - .xlsm

تقصد انك تريد وضع الفواتير تحت بعض في شيت المطبوعات. او عند استدعاء فاتورة 2 مثلا نقوم بظغط على زر طباعة يتم انشاء الفاتورة بدون فراغات كما في الصورة لاكن مستقلة

تفضل اخي =STXT(D21;TROUVE("DU";D21)+2;NBCAR(D21)) او =DROITE(D21;10) Facture3 OFFICENA.xlsm

طيب أخي كان من الأفضل وضع النتيجة المتوقعة في جدول اخر لكي تفهم المطلوب جيدا صراحة رغم كتابة الملاحظات لازلت لا أستوعب الفكرة جيدا ربما فهمي بطيئ

وعليكم السلام ورحمة الله تعالى وبركاته ممكن توضيح المطلوب اكثر او وضع عينة للنتيجة المتوقعة

تفضل اخي ضع هده المعادلة في الخلية B2 وسحبها لاخر صف لديك للحصول على اسماء المشرفين ليوم الأحد وبنفس الطريقة على كل ايام الأسبوع مع استبدال إسم العمود داخل المعادلة. بالتوفيق =SIERREUR(INDEX('الزيارات بأسماء المشرفين'!$A$2:$A$11;EQUIV(A2;'الزيارات بأسماء المشرفين'!$B$2:$B$11;0);EQUIV($B$1;'الزيارات بأسماء المشرفين'!$B$1:$B$1;0));"") تجربة الزيارات.xlsx

جربت الملف الأخير؟

تفضل اخي رغم ان الشرط موجود اصلا على الملف بمجرد كتابة رقم الفاتورة تظهر رسالة تخبرك بوجودها مسبقا مع امكانية استدعاء البيانات او افراغ الفاتورة لادخال بيانات جديدة لم اعلم هل قمت بتجربتها ام لا على العموم تمت اظافته الا زر الترحيل . أما بالنسبة للطباعة ماهو المطلوب ؟ فاتورة_MH.xlsm

تفضل اخي يمكنك استخدام احدى المعادلات التالية =SIERREUR(RECHERCHEH('بيانات الموظفين '!F2;'جدول المرتبات'!$B$3:$O$18;EQUIV('بيانات الموظفين '!E2;'جدول المرتبات'!$B$3:$B$18;0);0);"") ولاستخراج قيمة الراتب في شيت جدول المرتبات =SIERREUR(INDEX('جدول المرتبات'!$B$3:$O$18;EQUIV(Q6;'جدول المرتبات'!$B$3:$B$18;0);EQUIV(R6;'جدول المرتبات'!$B$3:$O$3;0));"") ورقة1.xlsx

طلبك غير مفهوم بالنسبة لي حاول اخي وضع عينة للنتيجة المتوقعة

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ..اليك الكود التالي لاستدعاء الفواتير بشرط رقم الفاتورة .مع اضافة ظهور اشعار بوجودها مسبقا في حالة كتابة رقمها في جدول الادخال كما جاء في طلبك . الكود لم ارفعه هنا قد تمت اضافته في حدث شيت ( مستند قيد) وان شاء الله نكون انتهينا من الخطوة الثانية. Sub Find_MH() Set Sh1 = Worksheets("مستند قيد") Set sh2 = Worksheets("اليومية العامه") Dim lastrow As Long Dim Mh As Long Dim iCont As Integer Dim r As Integer Dim c As Integer Dim MH2 As Worksheet Dim MH3 As Worksheet Dim Trouve As Range Application.ScreenUpdating = False If Len(Range("d5").Value) = 0 Then ' '<--التحقق من وجود قيمة في خلية البحث MsgBox "المرجوا ادخال رقم الفاتورة" Exit Sub End If With Sheets("اليومية العامه") 'في عمود (D) شيت الفواتير اليومية'<--- التحقق من وجود رقم الفاتورة Set Trouve = .Range("d:d").Find(what:=Sheet1.Range("d5"), LookIn:=xlValues, lookat:=xlWhole) If Trouve Is Nothing Then MsgBox (" !!!رقم الفاتورة غير مسجل مسبقا") Exit Sub Else End If End With MH1 = Sh1.Range("D5").Value ' '<--- في حالة تحقق الشرط With sh2 lastrow = .Cells(.Rows.Count, "b").End(xlUp).Row '+ 1 Mh = WorksheetFunction.Match(MH1, .Range("D5:D" & lastrow), 0) + 4 iCont = WorksheetFunction.CountIf(.Range("D5:D" & lastrow), MH1) End With X = 3 For c = 2 To 2 Sh1.Cells(X, 4) = sh2.Cells(Mh, c).Value ' '<---عمود D ( التاريخ - رقم الفاتورة _ الشركة_ ' Sh1.Cells(X + 1, 4) = sh2.Cells(Mh, c + 1).Value 'sh1.Cells(X + 3, 4) = sh2.Cells(Mh, c + 3).Value ' '<--- تم تعويضها بمعادلة '''=SI(D3="";"";CONCATENER(TEXTE($D$5;"0##########");" - ";$D$4;" - "&TEXTE('مستند قيد'!D3;"mm-yyyy"))) Sh1.Cells(X + 1, 6) = sh2.Cells(Mh, c + 15).Value ' '<---عمود F Sh1.Cells(X + 3, 6) = sh2.Cells(Mh, c + 17).Value Sh1.Cells(X + 2, 6) = sh2.Cells(Mh, c + 16).Value Sh1.Cells(3, 6) = sh2.Cells(Mh, c + 14).Value Sh1.Cells(3, 2) = sh2.Cells(Mh, c + 10).Value ' '<---عمود B Sh1.Cells(4, 2) = sh2.Cells(Mh, c + 11).Value Sh1.Cells(5, 2) = sh2.Cells(Mh, c + 12).Value Sh1.Cells(6, 2) = sh2.Cells(Mh, c + 13).Value X = X + 1 Set MH2 = Worksheets("اليومية العامه") Set MH3 = Worksheets("مستند قيد") lastrow = MH2.Cells(Rows.Count, "F").End(xlUp).Row If MH2.FilterMode Then MH2.ShowAllData Worksheets("مستند قيد").Range("b9:F51").ClearContents ' '<---افراغ البيانات السابقة With MH2.Rows(6) ' '<--- تحديد رقم صف رؤؤوس الاعمدة ' '<--- تحديد عمود وجودة القيمة المبحوث عنها Row4 ___________________________________' '<--تحديد خلية البحث .AutoFilter Field:=4, Criteria1:=Worksheets("مستند قيد").Range("D5").Value ' ' <--- _____________________فلترة البيانات If MH2.Range("d6:d" & lastrow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then MH2.Range("F7:J" & lastrow).SpecialCells(xlCellTypeVisible).Copy MH3.Range("b" & Rows.Count).End(3)(2) ' '<--- مكان اللصق MH3.Range("A9:G51").Borders.LineStyle = xlContinuous ' '<---تسطير الجدول End If .Parent.AutoFilterMode = False ' '<---الغاء الفلترة End With Next Application.ScreenUpdating = True End Sub واليك اخي كود اضافي للترحيل من شيت الفاتورة الى شيت الفواتير اليومية ربما تحتاجه يوما ما. Sub TARHIL2() Dim LastRowF1 As Integer Dim NextRowF2 As Integer Dim RowCount As Integer Dim rngF1 As Range Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Worksheets("مستند قيد") Set Sh2 = Worksheets("اليومية العامه") Dim Arr As Variant Arr = Array([b3], [d3], [f3], [b4], [d4], [f4], [f5], [f6]) For i = 0 To 7 If Arr(i) = "" Then MsgBox "المرجوا ادخال البيانات" Arr(i).Select Exit Sub End If Next i With Sh1 NextRowF2 = Sh2.Cells(Rows.Count, 6).End(xlUp).Row + 1 If NextRowF2 < 9 Then NextRowF2 = 7 LastRowF1 = .Cells(Rows.Count, 2).End(xlUp).Row - 1 Set rngF1 = .Range(.Cells(9, "B"), .Cells(LastRowF1, "g")) RowCount = rngF1.Rows.Count Sh2.Cells(NextRowF2, "F").Resize(RowCount, rngF1.Columns.Count).Value = rngF1.Value Sh2.Cells(NextRowF2, "B").Resize(RowCount).Value = .Range("d3").Value Sh2.Cells(NextRowF2, "C").Resize(RowCount).Value = .Range("d4").Value Sh2.Cells(NextRowF2, "d").Resize(RowCount).Value = .Range("d5").Value Sh2.Cells(NextRowF2, "E").Resize(RowCount).Value = .Range("d6").Value Sh2.Cells(NextRowF2, "L").Resize(RowCount).Value = .Range("b3").Value Sh2.Cells(NextRowF2, "M").Resize(RowCount).Value = .Range("b4").Value Sh2.Cells(NextRowF2, "N").Resize(RowCount).Value = .Range("b5").Value Sh2.Cells(NextRowF2, "O").Resize(RowCount).Value = .Range("b6").Value Sh2.Cells(NextRowF2, "P").Resize(RowCount).Value = .Range("F3").Value Sh2.Cells(NextRowF2, "Q").Resize(RowCount).Value = .Range("F4").Value Sh2.Cells(NextRowF2, "R").Resize(RowCount).Value = .Range("F5").Value Sh2.Cells(NextRowF2, "S").Value = .Range("F6").Value Sh1.Range("b2").Value = Sh2.Range("d" & Rows.Count).End(xlUp).Value + 1 End With End Sub بالتوفيق. في انتظار الرد بعد التجربة . فاتورة_MH.xlsm

ان شاء الله نمشي خطوة خطوة حتى تكمل المطلوب نبدا أولا بالترحيل ثم الاستدعاء 2-(ماهو معيار البحث) بمعنى سوف يتم استدعاء البيانات برقم الفاتورة او الكود او...... 3- وعند الانتهاء نقوم بتصميم الفاتورة للطباعة وبالنسبة للفورم المضاف لم تذكر دوره في الملف المرفق Sub Tarhil() Dim DL1%, DL2%, DL3%, MH% Application.ScreenUpdating = False DL1 = Range("B65500").End(xlUp).Row - 1 With Sheets("اليومية العامه") DL2 = .Range("B65500").End(xlUp).Row + 1 DL3 = .Range("R65500").End(xlUp).Row + 1 MH = DL2 + DL1 - 9 .Range("F" & DL2 & ":K" & MH) = Range("B9:G" & DL1).Value .Range("B" & DL2 & ":B" & MH) = Range("D3") 'التاريخ .Range("C" & DL2 & ":C" & MH) = Range("D4") 'اسم الشركة .Range("D" & DL2 & ":D" & MH) = Range("D5") 'رقم الفاتورة .Range("E" & DL2 & ":E" & MH) = Range("D6") 'كود الفاتورة .Range("L" & DL2 & ":L" & MH) = Range("B3") 'اسم العميل .Range("M" & DL2 & ":M" & MH) = Range("B4") 'التيلفون' .Range("N" & DL2 & ":N" & MH) = Range("B5") 'العنوان .Range("O" & DL2 & ":O" & MH) = Range("B6") 'المحافظة .Range("P" & DL2 & ":P" & MH) = Range("F3") 'شركة الشحن .Range("Q" & DL2 & ":Q" & MH) = Range("F4") 'اسم المندوب .Range("R" & DL2 & ":R" & MH) = Range("F5") 'رقم التيلفون .Range("S" & DL3) = Range("F6") 'خدمة التوصيل End With Application.ScreenUpdating = True End Sub officena 1.xlsm

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

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