اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

۩◊۩ أبو حنين ۩◊۩

05 عضو ذهبي
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    1,110

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    2

 نوع المحتوي 

مشاركات المكتوبه بواسطه ۩◊۩ أبو حنين ۩◊۩

    أوامرطباعة

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

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

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

    هل يمكن اضافه

    اخى الحبيب هل يمكن تحد ما يتم طباعة  من... الى  على اساس التسلسل

    اى  عن استخدام الكود يظهر بوكس ادخال من    الى      على اساس التسلسل

    من 1 الى  5  يتم طباعه الموظفين من واحد الى 5

    اة من 1 الى  1  يتم طباعه ورقه الموظف الذى تسلسه  1

    جزاك الله كل الخير والتقدير

    ارجو المساعد فى اضافة MsgBox

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه ۩◊۩ أبو حنين ۩◊۩

    السلام عليكم

    الاخ الكريم محمود

    نفس المشكله التى تقع معى

    يتم ارسال الملف حتى لو تم اخيار  NO

    دائما ما تظهر  MsgBox "تم إرسال الملف الى ماليه القاهرة بنجاج ... شكرا...", 64

    وهى موجوده فى اخر الكود

    الذى اضفته 

     If MsgBox("هل تريد إرسال الملف المرفق إيميل أم لا؟", vbYesNo, "Send Email") = vbNo Then Exit Sub

    اريد عند اخيار no  تظهر رسال تاكد عدم ارسال الملف  والخروج من الكود

    ارجو المساعد فى اضافة MsgBox

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    الاخوة الكرام  ... ارجو المساعده فى اضفه للكود

     اريد اضافه  MsgBox  للكود ... قبل تنفذه هل انت متاكد من ارسال المالف  ... اذا كان نعم يتم عمل الكود... اذا كان لا يتم الخروج من الكود

    اذا كانت الاجابه نعم يتم تنفيز الكود

    اذا كانمت الاجابه لا يتم الخروج من الكود

    لقد  نفذت الطلب على اكثر من كود الا اعجز عن تنفيذه على ذلك الكود

    
Option Explicit

Sub Mail_Range()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set Source = Nothing
    On Error Resume Next
    
    Set Source = Range("A31:Al53").SpecialCells(xlCellTypeVisible)
    
    On Error GoTo 0

     If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Tarek Zayed Allow" & Format(Date, "mm-yy")

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "aaaaaaa@yahoo.com"
           ' .CC = "aaaaaaa@yahoo.com"
            '.BCC = "aaaaaaa@yahoo.com"
            .Subject = "aaaaaaa"
            .Body = "aaaaaaaaaaaaaaaaaaa"
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
   End With
    
    MsgBox "تم إرسال الملف الى ماليه القاهرة بنجاج ... شكرا...", 64
End Sub

     

    تعديل كود ارسال الشيت الفعال بيانات اميل الخاص ب ( ياسر ابو البراء )

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    الساده الكرام  ..

    ارجو المساعده فى تعديل كود لاخ الجليل ياسر ابو البراء .. جذاه الله كل الخير والتقدير

    الكود يقو على ارسال نسخه بيانات وليس المعاادلان من الشيت الفعال اميل

    - المطلوب

    تغير  الشيت الفعال  الى اسم شيت وليكن شيت  a&b   

    اى نسخ الشيت a & b   بيانات وارساله اميل  واختيار ايضا اسم المصنف الجديد الذى يتم ارساله اميل ... يتم كتابته داخل الكود

    هلى يمكن المساعده فى ذلك 

    Option Explicit
Sub Mail_ActiveSheet_Using_Outlook()
    Dim fileExtStr          As String
    Dim fileFormatNum       As Long
    Dim sourceWb            As Workbook
    Dim destWb              As Workbook
    Dim tempFilePath        As String
    Dim tempFileName        As String
    Dim outApp              As Object
    Dim outMail             As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
        Set sourceWb = ActiveWorkbook
        ActiveSheet.Copy
        Set destWb = ActiveWorkbook
        With destWb
            If Val(Application.Version) < 12 Then
                fileExtStr = ".xls": fileFormatNum = -4143
            Else
                Select Case sourceWb.FileFormat
                    Case 51: fileExtStr = ".xlsx": fileFormatNum = 51
                    Case 52:
                        If .HasVBProject Then
                            fileExtStr = ".xlsm": fileFormatNum = 52
                        Else
                            fileExtStr = ".xlsx": fileFormatNum = 51
                        End If
                    Case 56: fileExtStr = ".xls": fileFormatNum = 56
                    Case Else: fileExtStr = ".xlsb": fileFormatNum = 50
                End Select
            End If
        End With
    
        'Change All Cells In The Worksheet To Values If You Want
        With destWb.Sheets(1).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
        '======================================
        'Save The New Workbook/Mail It/Delete It
        tempFilePath = Environ$("temp") & "\"
        tempFileName = Replace(sourceWb.Name, ".xlsm", "")
    
        Set outApp = CreateObject("Outlook.Application")
        Set outMail = outApp.CreateItem(0)
    
        With destWb
            .SaveAs tempFilePath & tempFileName & fileExtStr, FileFormat:=fileFormatNum
            On Error Resume Next
                With outMail
                    .To = "aaa@.com"   'Change Email
                    .CC = "aaa@.com"
                    .BCC = "aaa@.com"
                    .Subject = "بدلات "
                    .Body = " مع تحيات ..إدارة الشئون الادارية  )- 8240"
                    .Attachments.Add destWb.FullName
                    .Send
                End With
            On Error GoTo 0
            .Close savechanges:=False
        End With
    
        'Delete The File You Have Sent
        Kill tempFilePath & tempFileName & fileExtStr
    
        Set outMail = Nothing
        Set outApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

     

    نسخ نطاق من مصنف مغلق بدون فتحه على الإطلاق أي لا يتم فتح المصنف في الأكواد

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    اخى الحبيب ..... ياسر ابو البراء

    عمل رائع رائع ... والكود يعمل بشكل ممتاز.. وهذا مابحث عنه ... ولاكن وجدته بعد الانتهاء من موضوع   ( تصحيح خطاء فى كود )    الذى وضعت الحل المناسب له ...

     

    ولاكن إثراء للموضوع حاولت تطبيق كود Get Data From Closed Workbook

     على المرفق

    الا ان النتائح تاتى بشكل غريب ( #REF! )

    ارجو توضيح السسبب وإصلاحه الخطاء

    الملف الذى اريد جلب البيانات منه وهو مغلق هو  TIME SHEET TAREK EK 2017.xlsb من الشيت Zayed Allaw .. والنطاف من X18 : A1

    والملف الذى اريد جلب البيانت فيه هو Zayed Allaw Cairo.xlsb فى شيت Zayed Allaw .. والنطاف من X18 : A1

     

     

     

     

     

     

    Get Data From Closed Workbook.rar

    تصحيح خطاء فى كود

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

     

    الاخ العزيز ياسر .... جزاك الله حيرا على وقتك

    فعلا دائما ما اقع فى نفس الخطاء ... ععدم توضيح الامر بشكل وافر

    تقبل عزرى

    اخى الحبيب ياسر 

    1- الملف المراد نقل البيانات منه TIME SHEET TAREK EK 2017 من الشيت Zayed Allaw  النطاق من X19 : A1

    2- الملف المراد نقل البيانات اليه Zayed Allaw Cairo فى  الشيت Zayed Allaw  الى النطاق من X19 : A1 

    والملفين موجودن فى فولد واحد فى 

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

    New folder (2).rar

    تصحيح خطاء فى كود

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    الاخوة الكرام والساده الافاضل

    ارجو المساعده فى الاتى :-

    تم عمل كود يقوم بنسخ محدتوى محدد ولصقه فىشيت بداخل ملف اخر  ( TIME SHET ZAYED )

    والكود يعمل بشكل ممتاز 

    المطلوب ان يعمل الكود  حتى وان لم يكن الملفالمراد نقل البيانات اليه مفتوح ( TIME SHET ZAYED)

    هل يمكن المساعده فى تحقيق ذلك الامر

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

    Sub zayed_allaw()
    Application.ScreenUpdating = False
    Range("A1:X19").Select
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-12
    Windows("TIME SHET ZAYED.xlsx").Activate
    ActiveWindow.SmallScroll Down:=-18
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Windows("TIME SHEET TAREK EK 2017.xlsb").Activate
    Application.CutCopyMode = False
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

     

    ارسال شيت محدد إميل ( الاوتلوك )

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    الاخوة الكرام والساده الافاضل

    ارجو المساعده فى الاتى :-

    المطلوب

    يوجد ملف به اكثر من شيت..... والمطلوب

    عمل كود يقوم بارسال شيت محدد ( zayed) عن طريق الاميل .. إميل الاوتلوك

    على ان يكون الملف الذى يتم ارسال بيانات فقط وليس معادلات او ارتباطات ( قيمة فقط )

    هلى يمكن ذلك

    Book1.rar

    هل يمكن جعل معادله VLOOKUP بمتغيرين

    في منتدى الاكسيل Excel

    قام بنشر

    17 ساعات مضت, الشهابي said:

    أخي العزيز / أبو حنين

    إضافة لحل أستاذنا الكبير بن علية حاجي حفظه الله آمين

    هذه المعادلة قمت بإعدادها فأحببت أن أشارك بها لإثراء الموضوع 

    
=SUMPRODUCT(--(INDIRECT(CONCATENATE("cairo";"!";"B4:B10"))=N2)*(INDIRECT(CONCATENATE("cairo";"!";"D4:D10"))=H19);(INDIRECT(CONCATENATE("cairo";"!";"G4:G10"))))

     

    اخى العزيز الشهابى ...

    معادله ابداعيه .... لذا ارجو شرح المعادله بشكل وافى 

    حتى بم الاستفاده منها 

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

     

    هل يمكن جعل معادله VLOOKUP بمتغيرين

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه ۩◊۩ أبو حنين ۩◊۩

    10 ساعات مضت, بن علية حاجي said:

     

    السلام عليكم 

    اخى الحبييب بن علية حاجى جزاك الله كل الخير والتقدير

    سلمت يداك .. حل مبدع 

    ولى سوال

    كيف يمكن اصافه شيت اخر مثل شيت  Suez وشيت Clep

    لانهم اكثر من شيت 

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

    هل يمكن جعل معادله VLOOKUP بمتغيرين

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم

    الاخوة الكرام

    ارجو المساعده فى المعادله ( VLOOKUP)

    يوجد فى شيت CAIRO  وشيت ALX.  ارقام الموظفين واسماء التدريبات المرشحين لها ويوجد تواريخ هذه التدريبات

    ونلاحظ ان تدريب AA  له 3 مواعيد لان كل موظف له ميعاد محدد

    المطلوب فى شيت EXP

    عند اختيار مكان التدريب N1 ورقم الموظف  N2  واسم التدريب H19

    يتم جلب التاريخ الصحيح لتدريب الموظف والمرتبط باسم التدريب ومكان التدريب فى الخليه K8

    تدريب.rar

    كيف اكرر كود الترحيل في جميع الاوراق ضيف جديد

    في منتدى الاكسيل Excel

    قام بنشر

    الاخ الكريم الكود هيكون بهذاالشكل 

    Sub TARHEEELL()
    Dim FS As Worksheet, TS As Worksheet
    Dim R, ER1, ER2
    
    Set TS = Sheets("data")
    Set FS = ActiveSheet
    ER2 = TS.Range("A55555").End(xlUp).Row + 1

    Application.ScreenUpdating = False
Sheets("data").Unprotect Password:="aaa"
        If FS.Name <> "data" Then
            For ER1 = 3 To FS.Cells(Rows.Count, 1).End(xlUp).Row
                If FS.Cells(ER1, 1) <> "" And FS.Cells(ER1, 14) <> "مرحل" Then
                    TS.Cells(ER2, 1).Resize(1, 13).Value = FS.Cells(ER1, 1).Resize(1, 13).Value
                    FS.Cells(ER1, 14) = "مرحل"
                    ER2 = ER2 + 1
                End If
            Next ER1
        End If
    Application.ScreenUpdating = True
Sheets("data").protect Password:="aaa"

End Sub

     

    • Like 1
×
×
  • اضف...

Important Information

  I accept