abouelhassan

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

يتم نسخ المعادلة الموجودة فى الخلبة b1 الى اخر العمود شرط وجود بيانات فى العمود a تفضل اخى عسى يفيدك copy formula.xlsm

هل بالامكان تعديل الكود للاحتفاظ بنسخة بتاريخ اليوم بدون حذف القديمة استاذنا لان حدث لى مشكلة عند حذف القديمة مشكور وبارك الله فيك Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim strDate As String, DefPath As String Dim FileNameZip, FileNameXlsm Dim oApp As Object ActiveWorkbook.Save If MsgBox("åá ÊÑíÏ ÅäÔÇÁ äÓÎÉ ÇÍÊíÇØíÉ¿", vbInformation + vbMsgBoxRight + vbYesNo, "Zipping") = vbYes Then MakeSureDirectoryPathExists ("D:\BackUp\") If ActiveWorkbook Is Nothing Then Exit Sub DefPath = ActiveWorkbook.Path If Len(DefPath) = 0 Then MsgBox "Plz Save activeworkbook before zipping" & Space(12), vbInformation, "zipping" Exit Sub End If 'If Right(DefPath, 1) <> "\" Then ' DefPath = DefPath & "\" 'End If DefPath = "D:\BackUp\" Dim oFSO As FileSystemObject Dim oFolder As Folder Dim oFile As File Set oFSO = New FileSystemObject Set oFolder = oFSO.GetFolder(DefPath) For Each oFile In oFolder.Files oFile.Delete (True) 'Debug.Print oFile.Name Next 'oFile strDate = Format(Now, " dd-mmm-yy h-mm-ss") FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip" FileNameXlsm = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xlsm" 'On Error Resume Next If Dir(FileNameZip) = "" And Dir(FileNameXlsm) = "" Then ActiveWorkbook.SaveCopyAs FileNameXlsm newzip (FileNameZip) Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameZip).CopyHere FileNameXlsm On Error Resume Next Do Until oApp.Namespace(FileNameZip).items.Count = 1 Application.Wait (Now + TimeValue("0:00:01")) Loop On Error GoTo 0 Kill FileNameXlsm MsgBox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping" Else MsgBox "FileNameZip or/and FileNameXlsm exist", vbInformation, "zipping" End If End If End Sub Private Sub newzip(sPath) If Len(Dir(sPath)) > 0 Then Kill sPath Open sPath For Output As #1 Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) Close #1 End Sub كل الشكر والاحترام والتقدير

بارك الله فيك استاذنا اشكر حضرتك لمجهودك الكريم جدااااااااااا ولو امكن تعديل المكرو بالملف المرفق لاتمكن من اختيار العمود المرحل اليه المبلغ خالص الشكر والدعاء من القلب والله ماكرو ترحيل بقائمة منسدلة.xlsm

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

جميلة استاذى بس المشكلة عمود sheetname يتم نسخه فى الصفحات وهذا لايمكن عمله بالصفحات اشكرك جداااااااااااااااااااااااااااااا استاى الغالى انا وجدت من خلال البحث بالمنتدى كود نفذ لى المطلوب بس محتاج تعديل بسيط هو امكانيات اختيار العمود m1 او m2 او بس نفذ المطلوب يرحل كل المبالغ للعمود m1 اريده ان باختيار العمود يرحل اليه واريد كود استدعاء الكود هو Sub Transfer() Sheets("ترحيل واستدعاء").Activate For Each F In Range("e3:E27") If F <> "" Then X = F.Value Range(F.Offset(0, -4), F.Offset(0, 0)).Copy LR = Sheets(X).Range("A" & Rows.Count).End(xlUp).Row Sheets(X).Activate Range("A" & LR + 1).Select Selection.PasteSpecial xlPasteValues End If Next F Sheets("ترحيل واستدعاء").Activate Application.CutCopyMode = False Range("b3:f27").ClearContents MsgBox "تم الترحيل الى كل صفحة بنجاح" End Sub كل حبى واحترامى ترحيل واستدعاء.xlsm

كل عام وحضرتك بخير

اخى قد يفيدك هذا الموضوع احترامى

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

الاخوة وجدت كود احتاج تعديله ليناسب البرنامج وهو للاستاذ على محمد على فى هذه المشاركة مش عارف اعدله والله احتاج تعديل الكود ليطبق على الملف المرفق مع خالص شكرى وتقديرى Sub Transfer() Sheets("Main").Activate For Each F In Range("e2:E1000") If F <> "" Then x = F.Value Range(F.Offset(0, -4), F.Offset(0, 0)).Copy LR = Sheets(x).Range("A" & Rows.Count).End(xlUp).Row Sheets(x).Activate Range("A" & LR + 1).Select Selection.PasteSpecial xlPasteValues End If Next F Sheets("Main").Activate Application.CutCopyMode = False Range("A2:E1000").ClearContents MsgBox "تم الترحيل الى كل صفحة بنجاح" End Sub ترحيل واستدعاء.xlsx

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

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

اكثر الله خيرك استاذنا حبيبى لن اثقل على حضرتك هاحول اعملها بالفورمات سيلس الكود هو هو ويعمل تمام التمام التمام التمام انا فرحان جدااااااااااااااااااااا بيه ,وادعى لحضرتك من كل قلبى اسعدك الله مثل ما تسعدنا يارب

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

انا عايز معادلة جمع للصف مكانها مع خالص تحياتي لحضرتك

تمام تمام تمام كنت ناسى اكتب مجموع 1 ومجموع 2 ممكن استاذنا نغير كلمة Global Sum بالجمع عادى للصف مع خالص شكرى وتقديرى

الله الله الله الله عليك يا استاذنا كود ولا اروع بس مشكلة بسيطو عايز الجمع الى هو Global Sum عايزه يكون فى الصف47و 48 هو الان فى الصف 34و34 كل الحب والاحترام وتقديرى الشديد لسعة صدرك ربنا يكرمك يا رب استاذى وحبيبى

لم ازيله يا باشا موجود مخفى تمام حفظك الله ونجاك وأدام عليك نعمه انا فقط حاولت تعديل المعادلات وفشلت

استاذنا حاولت فى المعادلات وحاولت اعدل عليها فشلت انا والله محرج جدا من حضرتك عملت لحضرتك المعادلات المطلوب تنفيذها بالكود لو امكن حفظك الله الله يرضى عنك اخيك بمنتهى الاحترامMy_Repport_Final_1.xlsm

استاذنا انا اسف واجهتنى مشكلة فى المجموع النهائى عايز اغير المعادلة أنها تجمع من الصف الرابع وليس من الصف الثالث معادلة sum of oll حاجة جميلة بس عايز اعدل فيها محتاج شرح ازى اختار إلى محتاج أجمعه فيها والله انا اسف ليك اوى اوى اوى حبيبي

حاضر استاذنا الله يحفظك كل شكرى وتقديرى واحترامى استاذنا بارك الله فيك My_Repport.xlsm

استاذنا سليم حاصبيا الله يرضى عليك استاذنا بعد مسح رقم 1 الكود يستدعى تمام وف الاخر يخرج رسالة ايرور اضغط end الكود يجمع كل الارقام بما فيها الاجمالى واذا تركته يجمع ناقص سطر اريده يجمع كل السطور ما عاد سطر الذى به الاجمالى الى فى اخر كل شهر معلش استاذنا وبردوا الكود اخرج رسالة run time error13 عندما اضغط عليه يظهر السطرين الاتتين بالاصفر Bol = Application.Evaluate _ ("ISREF('" & R.Range("A" & k) & "'!A1)") معلش استاذى وحبيبى سامحنى والله بارك الله فى حضرتك اللهم امين New Microsoft Word Document.docx

بارك الله لك وبك استاذى الحبيب تم اسندعاء التقرير تمام بس وقف الكود عند السطرين Bol = Application.Evaluate _ ("ISREF('" & R.Range("A" & k) & "'!A1)") حفظك الله وكمان حضرتك بعد مااضفت الكود لملفى لاحظت انه يستدعى البيانات ويجمعها حتى السطر قبل الاخير الذى يحوى بيانات بينما اخر خلية بها بيانات لا يجمعها انا اسف استاذى الحبيب هنا استاذنا فى الشيت1 المجموع 550 بينما التقرير 450 حبيبى يا استاذ سليم اسف والله انى ازعجك بطلباتى My_Repport.xlsm

هذا هو الملف الصحيح حفظك الله تقرير.xls

استاذى ومعلمى سليم حاصبيا والله يعجز لسانى عن شكرك وادعوا لك عن ظهر الغيب باستمرار والله ربنا يحفظك يبارك فى عمرك ويعطيك كل خير الدنيا اللهم امين يارب حضرتك حبيبى والله نفذت كل التعليمات ولكن توقف الكود عند هذين السطرين If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _ CDate(Act_sh.Cells(x, 1)) <= End_Dat Then كل التقدير والشكر وخالص الدعاء لحضرتك حفظك الله وحفظ ال بيتك اجمعين