abouelhassan

ربنا يبارك لك استاذ سليم

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

الملف يعمل لدى وزر تكبير وتصغير تمام تواتي 31.xlsm

نفس مهمة الفورم بالمعادلات اتمنى تعجبك USER_FORM - Copy.xlsm

تفضل USER_FORM - Copy.xlsm

تفضل تواتي 31.xlsm

اخواتى هذا الكود اهدانى اياه الاستاذ ياسر خليل موسوعة الاكسيل يقوم بترحيل البيانات الى الصفحات المختارة بقائمة منسدلة فى سطور الى عمود اختار العمود المرحل اليه من قائمة منسدلة موضح بالملف التعديل المطلوب هو بدل ما اكتب التاريخ ورقم المستند فى كل سطر تحديد خلية واحدة اكتب بها التاريخ وخلية اكتب فيها رقم المستند واختار الصفحات عادى من كل سطر واضيف المبالغ فيتم الترحيل الى كل الصفحات Sub Test() Dim x, ws As Worksheet, sh As Worksheet, sName As String, lr As Long, r As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(25, 1).End(xlUp).Row For r = 3 To lr sName = CStr(ws.Cells(r, 5).Value) If Evaluate("ISREF('" & sName & "'!A1)") Then Set sh = ThisWorkbook.Worksheets(sName) m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 x = Application.Match(ws.Range("G2").Value, sh.Rows(1), 0) If Not IsError(x) Then sh.Cells(m, 1).Resize(1, 4).Value = ws.Cells(r, 1).Resize(1, 4).Value sh.Cells(m, x).Value = ws.Cells(r, 6).Value End If End If Next r Application.ScreenUpdating = True Range("A3:f24").ClearContents MsgBox "Done...", 64, "" End Sub اخيكم بحاجة للمساعدة فى هذا الموضوع مع الشكر تعديل كود الترحيلل بتثبيت التاريخ ورقم المستند.xlsm

شكر وتقدير واحترام استاذنا

ربنا يحفظك يارب ويديك الصحة والعافية ويبارك لك في اسرتك الكريمة استاذ سليم هذا الموضوع رائع انا متابعه واستفدت منه ربنا يبارك لحضرتك والله

برجاء التكرم بالمساعدة فى المطلوب بالمرفق جزاكم الله خير اساتذتى الافاضل استاذ سليم سليم حاصبيا لو امكن المساعدة الله يبارك لك يارب اخيك باحترام شديد جدا ترحيل واستدعاء.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 بالجمع عادى للصف مع خالص شكرى وتقديرى