عبدالله المجرب

السلام عليكم اليك هذا الرابط ففيه طلب مشابه http://www.officena.net/ib/index.php?showtopic=39252

الله يسلمك ابو الحسن وشكراً لك ولم استطيع ان اقاوم شغفي بحبكم وحب اوفيسنا

السلام عليكم اخي فضل جرب هذا الكود ستقوم باختيار المادة التي تريد عمل فرز لها ثم تضغط الزر وسيتم ان شاء الله الترتيب في الورقتين Sub Abu_Ahmed_Srt() On Error Resume Next Application.ScreenUpdating = False x = Selection.Column For i = 1 To 2 Sheets(i).Select Range(Cells(2, x), Cells(11, x)).Sort Key1:=Cells(2, x), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Next ورقة1.Select End Sub

السلام عليكم في الملف المرفق عد الكود ليصبح هكذا Sub GetMe() Dim MySer As String * 99 Call GetSerialNumber(0, MySer) [E5] = MySer If [E5] <> "ضع هنا رقم القرص الصلب" Then MsgBox "عفواً البرنامج غير مسجل", vbCritical, "تنبيه": Application.Quit End If End Sub طبعاً لا تنسى ان تضع رقم القرص الصلب في المكان المحدد ثم ضع في حدث فتح الملف ThisWorkbook Private Sub Workbook_Open() RunMe End Sub ============== اما بالنسبة للكمبوبوكس فمن خصائصه اذهب الى RowSource ثم ضع المدى الذي ترغب بعد يساوي "="

الحمدلله ان كان هذا طلبك

شكراً لكم اخواني والحمدلله حالي اليوم احسن ولله الحمد

السلام عليكم شاهد هذا الرابط وان شاء الله تستفيد منه http://www.officena.net/ib/index.php?showtopic=28561&hl=&fromsearch=1

السلام عليكم بعد اذن الغالي ابو نصار هل تقصد هذه http://www.officena.net/ib/index.php?showtopic=13997&st=0&p=60720&#entry60720

فسر اكثر ماذا تقصد ب 5 ساعات والمطلوب 10 ساعات

السلام عليكم اتبع الرابط ففيه طلب مشابه لما تريد المشاركة 10 من هنا

شكراً للجميع واخص بالشكر الاستاذان الفاضلان بن علية وطارق محمود

السلام عليكم اخواني الكرام اشكركم جميعاً على مشاعركم النيلة وكرم الاخلاق التي غمرتموني بها يعلم الله ان هذه اللفته الكريمة منكم انستني الالم واصريت الاا ان اكتب الرد كعرفان بجميلكم ولفتتكم الكريمة و الحمدلله على كل حال

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

هل تقصد ورقة العمل ام الفورم ام ماذا

جرب هذا Private Sub CommandButton1_Click() Dim I As Integer For I = 2 To Sheets.Count LR = Sheets(I).Range("A" & Rows.Count).End(xlUp).Row + 1 If Sheets(I).Range("A" & LR).Offset(0, 1).Value = "الاجمالى" Then GoTo 0 Sheets(I).Range("A" & LR).Value = TextBox1 Sheets(I).Range("A" & LR).Offset(0, 1).Value = TextBox2 0 Next Unload Me End Sub

السلام عليكم ضع هذا الكود في زر امر الترحيل Private Sub CommandButton1_Click() Dim I As Integer For I = 2 To Sheets.Count LR = Sheets(I).Range("A" & Rows.Count).End(xlUp).Row + 1 Sheets(I).Range("A" & LR).Value = TextBox1 Sheets(I).Range("A" & LR).Offset(0, 1).Value = TextBox2 Next Unload Me End Sub

السلام عليكم انا استعمل قوقل كروم والتنزيل يعمل بمجرد الضغط على المرفقات

ما شاء الله تبارك الرحمن ملومات جديدة بنتعلمها كل يوم بارك الله فيك استاذ محمد يحياوي وكل الشكر للاستاذان الكريمان ابو عبدالله (محمد صالح) ابونصار (العيدروس)

اخي الفاضل يمكن عمل طلبك لكن ستواجهنا مشكلة الخلايا المدموجة . فشوف لك حل اولاً معاها

السلام عليكم بعد اذن استاذنا الفاضل والماسة المنتدى اضع هنا شرح لطريقة كتابة الكود والدالة في المحرر كنت قد اعددته من فترة

السلام عليكم اين المرفقات

السلام عليكم جرب عمل من خصائص الفورم شاهد المرفق

السلام عليكم بعد اذن المعلم الصامت ذو المكانة العالية بن عليه جرب هذا الكود Sub PRINT_ALL() Dim I As Integer For I = 9 To Sheets("التحضير اليومي").Range("b" & Rows.Count).End(xlUp).Row w = Sheets("التحضير اليومي").Cells(I, 2).Value [B7] = w ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next I End Sub

السلام عليكم اليك بهذا الموضوع المشابه http://www.officena.net/ib/index.php?showtopic=19465

اخي الفاضل وبعد اذن ابو نصار ارفق ملف افضل من وضع صورة