Ali Mohamed Ali

تفضل لا يمكنك العمل بهذه الدالة قبل 1900 ولكن هناك دالة معرفة وهى XDATEYEARDIF ..... وهذا هو كودها Function XDATEYEARDIF(xdate1, xdate2) As Long Dim YearDiff As Long Dim i As Long, D1 As String, D2 As String D1 = xdate1 For i = 1 To 7 D1 = Replace(D1, Format(i, "dddd"), "") D1 = Replace(D1, Format(i, "ddd"), "") Next i D2 = xdate2 For i = 1 To 7 D2 = Replace(D2, Format(i, "dddd"), "") D2 = Replace(D2, Format(i, "ddd"), "") Next i YearDiff = Year(D2) - Year(D1) If DateSerial(Year(D1), Month(D2), Day(D2)) < CDate(D1) Then YearDiff = YearDiff - 1 XDATEYEARDIF = YearDiff End Function اشخاص - 1.xlsm

وعليكم السلام-تفضل هذا الكود Sub PrintPDF() Call Save_PDF End Sub Function Save_PDF() As Boolean Dim Thissheet As String, ThisFile As String, PathName As String Dim SvAs As String Application.ScreenUpdating = False Thissheet = ActiveSheet.Name ThisFile = ActiveWorkbook.Name PathName = ActiveWorkbook.Path SvAs = PathName & "\" & Thissheet & ".pdf" On Error Resume Next ActiveSheet.PageSetup.PrintQuality = 600 Err.Clear On Error GoTo 0 On Error GoTo RefLibError ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SvAs, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True On Error GoTo 0 SaveOnly: MsgBox "A copy of this sheet has been successfully saved as a .pdf file: " & Chr(13) & Chr(13) & SvAs & _ "Review the .pdf document. If the document does NOT look good, adjust your printing parameters, and try again." Save_PDF = True GoTo EndMacro RefLibError: MsgBox "Unable to save as PDF. Reference library not found." Save_PDF = False EndMacro: End Function وتم تجربة الكود على الطابعة , يعمل بنجاح وهذا هو الدليل قمت بعمل سكان لك للورقتين Scan1.pdf Scan2.pdf A4 VERSION1.xlsm

وعليكم السلام -تفضل تم عمل قوائم منسدلة لتسهيل الإدخال بصفحة العمليات .. كما تم منع ادخال المكرر بعمود الرمز وعمود الإسم كماتم الإستعانة بكود من أكواد استاذنا الكريم سليم حاصبيا للترحيل , له منا كل المحبة والإحترام وأعانه الله دائما على مساعدة الجميع وهو : Option Explicit Sub Salim_code() Application.ScreenUpdating = False Dim Filt_Rg As Range Dim M As Worksheet Dim Sh As Worksheet Dim i% Set M = Sheets("العمليات") Set Filt_Rg = M.Range("A12").CurrentRegion If M.AutoFilterMode Then Filt_Rg.AutoFilter End If i = 4 Do Until M.Range("F" & i) = vbNullString If Not Application.Evaluate("ISREF('" & M.Range("F" & i) & "'!A1)") Then Sheets.Add(, M).Name = M.Range("F" & i) End If i = i + 1 Loop For Each Sh In Sheets If Sh.Name <> M.Name Then Sh.Range("B1").CurrentRegion.Clear Filt_Rg.AutoFilter 6, Sh.Name Filt_Rg.SpecialCells(12).Copy Sh.Range("B1") Sh.Range("B1").CurrentRegion.Columns.AutoFit End If Next M.Select If M.AutoFilterMode Then Filt_Rg.AutoFilter End If Application.ScreenUpdating = True End Sub تجربة ملاك 2020.xlsb

تفضل هذه المعادلة لعد أحرف الخلية =LEN(A4) أما بالنسبة لتحديد كتابة 31 حرف أو أقل فقط بالخلية فهذا يتم من خلال DataValidation كما بالصورة وتم تنفيذ ذلك على الملف بالفعل دالة عدد الاحرف.xlsx

تفضل اخى الكريم -يمكنك استخدام هذا الكود ... تم التعــديــل من فضلك عليك بأستخدام خاصية البحث بالمنتدى قبل رفع مشاركتك حتى لا يتم اهدار مزيد من الوقت فى موضوعات قد تكررت وتم تناولها عشرات المرات Sub Test() Dim rng1 As Range Dim str_search As String ThisWorkbook.Sheets("البداية").Activate str_search = Range("b6").Value ThisWorkbook.Sheets("التقرير").Activate Set rng1 = Sheets("التقرير").Range("a:a").Find(str_search, , xlValues, xlWhole) If rng1 Is Nothing Then Dim lastRow As Long lastRow = ThisWorkbook.Sheets("التقرير").Range("A1000000").End(xlUp).Row lastRow = lastRow + 1 With ThisWorkbook.Sheets("التقرير") .Range("A" & lastRow).Value = Sheets("البداية").Range("B6").Value .Range("B" & lastRow).Value = Sheets("البداية").Range("B7").Value .Range("C" & lastRow).Value = Sheets("البداية").Range("B8").Value End With Sheets("البداية").Range("B6").Value = "" Sheets("البداية").Range("B7").Value = "" Sheets("البداية").Range("B8").Value = "" Else MsgBox str_search & " موجود مسبقا" ThisWorkbook.Sheets("البداية").Activate End If End Sub test 3.xlsm

وعليكم السلام-تم عمل المطلوب وزيادة ... فقد تم تنسيق شكل الفاتورة وعمل قواءم منسدلة لأسماء الأصناف وأسماء العملاء حتى يتم الأختيار من بينهم وان لا يوجد مجال للخطأ عند الكتابة -بارك الله فيك وأتمنى ان ينال إعجابك فاتورة_3.xlsm

وعليكم السلام بارك الله فيك وزادك الله من فضله

بارك الله فيك استاذ محي ... ولإثراء الحل -يمكنك استخدام هذه المعادلة , مصفوفة (Ctrl+Shift+Enter) =SUMPRODUCT(0+(0&TRIM(MID(SUBSTITUTE(B2,"+",REPT(" ",10)),ROW($A$1:$A$10)*10-9,10)))) معادلة جمع1.xlsm

يمكنك هذا بهذه المعادلة =IF(ROWS($A$1:A1)>DAY(EOMONTH(DATE($D$2,$F$2,1),0)),"",DATE($D$2,$F$2,ROWS($A$1:A1))) 81.xlsx

تفضل اليك طلبك - وهذا شكل القائمة المنسدلة بالملف المرفق ... كما بالصورة 0001 .xlsm

وعليكم السلايمكنك استخدام هذا الكود لذلك Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If (Not Application.Intersect(Target, Me.Range("d9:M18,D19:E19")) Is Nothing) Then Cancel = True Target.Interior.ColorIndex = 15 End If End Sub Cells Colored.xlsm

بارك الله فيك استاذ صالح وجعل هذا العمل فى ميزان حسناتك - ورحم الله والديك , اللهم اجعلهم فى اعلى الدرجات وأدخلهم فسيح جناتك ... جنات الفردوس الأعلى واغفر لهم وارحمهم اللهم وسع فى رزقك استاذ صالح واصلح لك اولادك واجعلهم يارب ممن يستمعون القول فيتبعون احسنه وبارك اللهم لك فيهم

أحسنت استاذ أحمد بارك الله فيك

يمكنك استخدام هذه المعادلة =IFERROR(LOOKUP(1,0/(tarheel!$C$2:$C$200=$C$1)/(tarheel!$B$2:$B$200=E$2),tarheel!$A$2:$A$200),"") ترحيل3.xlsm

وعليكم السلام كان عليك لزاما استخدام خاصية البحث بالمنتدى قبل رفع مشاركتك فقد تم تناول هذا الموضوع مرات عدة ومنها ربط الصورة بالإسم وهذا فيديو أيضاً للشرح ويمكنك تحميل ملف الشرح أسفل الفيديو استدعاء صورة الموظف من مجلد بالاكسيل Vlookup Picture VBA بعد كل هذا فقمت بحل طلبك بدالة معرفة ... فيمكنك وضع هذه المعادلة ابتداءا من الخلية B2 سحباً للأسفل =IF(A2="","",VLOOK_Pic1($A2)) وهذا هو كود الدالة Function VLOOK_Pic1(PicName) Dim CurrentCel As Range, Pic As Shape PicName = PicName: MyPath = ThisWorkbook.Path & "\Data\": PicName = MyPath & PicName: ChkPic = Array(".jpg", ".bmp", ".gif", ".png") Set CurrentCel = Application.Caller Set CurrentCel = CurrentCel.MergeArea For Each Pic In ActiveSheet.Shapes If Pic.Type = msoLinkedPicture Then If Pic.Top >= CurrentCel.Top And Pic.Top < CurrentCel.Top + CurrentCel.Height Then Pic.Delete Exit For End If End If Next For X = LBound(ChkPic) To UBound(ChkPic) If Not Dir(PicName & ChkPic(X), vbDirectory) = vbNullString Then Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height): VLOOK_Pic1 = "" Exit For Else VLOOK_Pic1 = "لا توجد صورة" End If Next End Function khalid.rar

يمكنك استخدام هذا الكود -فقد تم ضبط الملف و عمل قائمة منسدلة ديناميكية وبدون فراغات لأسماء العملاء ... كما تم ادخال معادلة أيضاً لمعرفة طبيعة كل صنف هل بالكيلو ام بالحبة Sub TARHEEL() If IsEmpty(Cells(5, 2)) Then MsgBox "يــرجــى إدخــال رقــم الفــاتــورة" Exit Sub End If Dim R As Integer Dim xNewR As Integer For R = 14 To 23 If IsEmpty(Cells(R, 2)) Then Exit Sub xNewR = Sheets("SLS").Cells(1, 1).CurrentRegion.Rows.Count + 1 Sheets("SLS").Cells(xNewR, 1) = Cells(5, 2) Sheets("SLS").Cells(xNewR, 2) = Cells(5, 6) Sheets("SLS").Cells(xNewR, 3) = Cells(7, 3) Sheets("SLS").Cells(xNewR, 4) = Cells(8, 3) Sheets("SLS").Cells(xNewR, 5) = Cells(R, 1) Sheets("SLS").Cells(xNewR, 6) = Cells(R, 2) Sheets("SLS").Cells(xNewR, 7) = Cells(R, 3) Sheets("SLS").Cells(xNewR, 8) = Cells(R, 4) Sheets("SLS").Cells(xNewR, 9) = Cells(R, 5) Sheets("SLS").Cells(xNewR, 10) = Cells(R, 6) Cells(R, 2) = "" Cells(R, 4) = "" Cells(R, 5) = "" Next Do Loop Cells(5, 2) = "" End Sub كود ترحيل الفاتورة.xlsm

طبعاً بعد اذن استاذنا عبد الرحيم ... ولإثراء الحل - تفضل على الرغم من تكرار هذه الموضوعات بالمنتدى 19.xlsm

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

تفضل يمكنك استخدام هذه المعادلة =SUMPRODUCT(SUMIF(INDIRECT("'"&sheets&"'!"&"b2:b100"),A2,INDIRECT("'"&sheets&"'!"&"d2:d100"))) تجريبى1.xlsx

وعليكم السلام-يمكنك استخدام هذه المعادلة ...وان لم يكن هذا المطلوب فعليك تنظيم ملفك وشرح المطلوب بكل دقة =SUMIFS($E$39:$E$375,$F$39:$F$375,B$5,$A$39:$A$375,$A6) شغل لوادروسيارات1.xlsx

وعليكم السلام-تفضل قوائم 2021-.xlsb

تفضل لك ما طلبت قائمة منسدلة.xlsx

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

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

وعليكم السلام -فقط للحفظ التلقائى ... عليك بوضع هذا الكود فى حدث ThisWorkBook Private Sub Workbook_BeforeClose(Cancel As Boolean) If Saved = False Then ActiveWorkbook.Save End If End Sub Protect.xlsb