محمد هشام.

قم بتصميم 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

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

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

ترتيب (4).xlsx

تفضل جرب ربما هدا ما تقصد ترتيب.xlsx

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Copysh() Dim SourceSht As Worksheet Set SourceSht = Sheets("sheet1") Application.ScreenUpdating = False Set Closesh = Workbooks.Open(ThisWorkbook.Path & "\تسويات العهد.xlsm", Password:="123") SourceSht.Copy After:=Closesh.Sheets(Closesh.Sheets.Count) 'حدف الاشكال ActiveSheet.Shapes("copy").Delete ActiveSheet.Shapes("Rounded Rectangle 5").Delete ActiveSheet.Shapes("شكل بيضاوي 1").Delete ActiveSheet.Shapes("صورة 5").Delete Closesh.Close SaveChanges:=True Application.ScreenUpdating = True End Sub بنامج تسوية العهدة.xlsm تسويات العهد.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته كان من الافضل رفع مثال للنتيجة المطلوبة مع تحديد النطاق المراد حدف الكلمات بداخله .... تفضل اخي يمكنك استخدام الكود التالي لحدف جميع الكلمات والحروف الانجليزية الموجودة في ورقة العمل مع الاحتفاظ بالباقي Sub Remove_specific_Value() Dim A As String * 1 Dim B As String * 1 Dim i As Integer Dim S As String Application.ScreenUpdating = False ' يمكنك الاضافة ما تشاء في السطر التالي 'مثال "),-,_,@,/,.,<,>,;,?,é,;,=,+" Const MH = "a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z, A, B, C, D, E, F, G ,H ,I ,J, K ,L ,M ,N ,O ,P ,Q, R ,S ,T ,U, V, W ,X ,Y, Z" Const MH2 = "" ' كما يمكنك هنا استبدال الحروف المحدوفة بشيئ معين' Range("A1").Resize(Cells.Find(what:="*", SearchOrder:=xlRows, _ SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _ Cells.Find(what:="*", SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, LookIn:=xlValues).Column).Select ' For Each cell In Selection If cell <> "" Then S = cell.Text For i = 1 To Len(MH) A = Mid(MH, i, 1) B = Mid(MH2, i, 1) S = Replace(S, A, B) Next cell.Value = S Debug.Print "celltext "; (cell.Text) End If Next cell Range("A3").Select Application.ScreenUpdating = True End Sub وهدا مثال لطلبك مثال _mh.xlsm

تفضل اخي المشكلة في تحديد نطاق قاعدة البيانات لديك قد تم تعدبلها لحدود 50000 صف بالتوفيق...... 779215434_.xls