abouelhassan

تظهر عندى صحيحة راجع اعدادات اللغة من كنترول بانل

فكرة رائعة استاذنا الرائد سلمت يمينك فعلا جميلة ومفيدة

الملف محمى بباسورد اخى اسم المستخدم ayman الباس 123

تفضل فتح صفحة انترنت بالفورم.xlsm

شاهد هذا الموضوع عله يفيدك

للرفع رفع الله مقداركم

جرب الريجيسترى التالى عله يفيدك Excel_11.rar وجرب الكود التالى للاستاذ محمد طاهر ان شاء الله تتحل المشكلة Sub Enable_All_Right_Click_Menus() 'This will enable all BuiltIn Command bars Dim Cbar As CommandBar For Each Cbar In Application.CommandBars Cbar.Enabled = True Next End Sub

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

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

الملف يعمل لدى وزر تكبير وتصغير تمام تواتي 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