شوقي ربيع

لسلام عليكم هي مجرد فكرة تعتمد على نسخ محتويات اليست في مصنف جديد ثم طباعته ثم اغلاق المصنف Sub Test_Print() Dim Tableau() As Variant Dim i As Integer Dim j As Byte Application.DisplayAlerts = False Workbooks.Add Tableau() = ListBox1.List j = ListBox1.ColumnCount i = ListBox1.ListCount Range("A1:" & Cells(i, j).Address) = Tableau() ActiveWorkbook.PrintOut ActiveWorkbook.Close False Application.ScreenUpdating = True End Sub تحياتي

السلام عليكم الاخ عادل ابو زيد الاخ مراد بديار شكرا لتعقيبكما ولاشكر على واجب تحياتي

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

السلام عليكم غدا ان شاء الله تجد الملف المعدل كما طلبت

السلام عليكم الرجاء ادراج ملف توضيحي لنعمل الازم ضع فيه جميع الاستفسارات والطلبات

السلام عليكم تفضل اخي Sub test() Dim Sh As Worksheet Dim i As Integer, r As Integer Dim Lr As Long, Lrr As Long Set Sh = ThisWorkbook.Sheets("áãÌãæÚ") Sh.Range("A2:E1000").Clear For i = 2 To Worksheets.Count Lrr = Sheets(i).Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To Lrr ary = Array(Sheets(i).Range("A" & r), Sheets(i).Range("B" & r) _ , Sheets(i).Range("C" & r), Sheets(i).Range("D" & r) _ , "ÕÝÍÉ " & Sheets(i).Name) Lr = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 Sh.Range("A" & Lr).Resize(1, 5) = ary Next Next End Sub جمع الصفحات.rar

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

جرب هذا اكسل التجااااااارب.rar

السلام عليكم على السريع لاكن جميل جزاك الله خيرا استادنا القدير

استبدل الكود الذي في الملف بهاذا الكود فهو افضل واصح Option Explicit Sub TEST() Dim Sh As Worksheet Dim lr As Long, Lc As Long Dim r As Integer, iCont As Integer Dim xx As Double Dim T, TT T = Time$ If T <= "17:00:00" Then Set Sh = ThisWorkbook.Sheets("feuil1") lr = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row If Sh.Range("B1") = Date Then MsgBox "áÇíãßäß ÊÛííÑ ÇáÈíäÇÊ áÇßËÑ ãä ãÑÉ æÇÍÏÉ ÞãÊ ÈÇáÝÚá ÈÊÛííÑ ÇáÈíäÇÊ áåÐÇ Çáíæã" Else For r = 1 To lr Lc = Sh.Cells(r, Rows.Column).End(xlToRight).Column If Sh.Cells(r, 2) = "" Then Sh.Cells(1, 2) = Date Sh.Range("A" & r).Resize(1, 2).Copy Sh.Range("B" & r) Else Sh.Range("A" & r).Resize(1, Lc).Copy Sh.Range("B" & r) Sh.Range("B1") = Date End If Next End If Else MsgBox "áÇíãßäß ÇÌÑÇÁ ÚãáíÉ ÇÏÎÇá ÌÏíÏÉ ÇáÇ ÈÚÏ ÇáÓÇÚÉ ÇáÎÇãÓÉ ãÓÇÁ" End If End Sub

السلام عليكم تفضل Option Explicit Sub TEST() Dim Sh As Worksheet Dim lr As Long, Lc As Long Dim r As Integer, iCont As Integer Dim xx As Double Dim T, TT T = Time$ If T <= "17:00:00" Then Set Sh = ThisWorkbook.Sheets("feuil1") lr = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row Lc = Sh.Cells(1, Rows.Column).End(xlToRight).Column If Sh.Cells(1, Lc) = Date Then MsgBox "áÇíãßäß ÊÛííÑ ÇáÈíäÇÊ áÇßËÑ ãä ãÑÉ æÇÍÏÉ ÞãÊ ÈÇáÝÚá ÈÊÛííÑ ÇáÈíäÇÊ áåÐÇ Çáíæã" Else For r = 2 To lr Lc = Sh.Cells(r, Rows.Column).End(xlToRight).Column If Sh.Cells(r, 2) = "" Then Sh.Cells(1, 2) = Date Sh.Range("A" & r).Resize(1, 2).Copy Sh.Range("B" & r) Else Sh.Cells(1, Lc + 1) = Date Sh.Range("A" & r).Resize(1, Lc).Copy Sh.Range("B" & r) End If Next End If Else MsgBox "áÇíãßäß ÇÌÑÇÁ ÚãáíÉ ÇÏÎÇá ÌÏíÏÉ ÇáÇ ÈÚÏ ÇáÓÇÚÉ ÇáÎÇãÓÉ ãÓÇÁ" End If End Sub rabie.rar

السلام عليكم ضع هذا الكود في ThisWorkbook Private Sub Workbook_SheetActivate(ByVal Sh As Object) MsgBox Sh.Name End Sub

السلام عليكم رمضان كريم هذا البرنامج استوحيته من موضوع مساعدة في إضافة ترحيل واستخراج كشف وبحث للاخ 1 modarsoos على الرابط http://www.officena.net/ib/index.php?showtopic=48332 بالامس شاهدة الملف الخاص بك اخي1 modarsoos واعجبني وضهرت مباشرتا في عقلى تصور جميل فترجمة هذا التصور الى برنامج يعتمد على الفورم اليوم اضعه بين ايديكم جميعا للافادة تحياتي العاشق للفورم اخوكم شوقي ربيع برنامج خاص بالمحاسبة والجرد لصيانة الهاتف.rar

الموضوع مكرر الحل في الرابط التالي http://www.officena.net/ib/index.php?showtopic=48343

تفضل Sub test() Dim lr As Long, Lrr As Long Dim R As Integer, iCont As Integer Dim xx As Double lr = Feuil1.Cells(Rows.Count, 1).End(xlUp).Row For R = 1 To lr xx = Feuil1.Cells(R, 1) iCont = WorksheetFunction.CountIf(Feuil2.Columns(R), xx) If xx <> 0 Then If iCont > 0 Or Feuil2.Cells(R, 1) = xx Then GoTo RabieCont Feuil2.Cells(R, 1) = xx If Feuil1.Cells(R, 2) = "" Then Feuil1.Cells(R, "A").Resize(1, 2).Copy Cells(R, "B") Else lc = Feuil1.Cells(R, Rows.Column).End(xlToRight).Column Feuil1.Cells(R, "A").Resize(1, lc).Copy Cells(R, "B") End If RabieCont: End If Next End Sub rabie.rar

لمرفق الاول به خطاء بسيط في الكود وهذا المرفق الاصح استبانة بدائل.rar

السلام عليكم رمضان كريم تفضل اخي الكريم استبانة بدائل.rar

هذا من ذوقك اخي الحبيب شكرا لكلماتك الجميلة رمضان كريم تحياتي

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

السلام عليكم كل الشكر للاخ الحبيب حمادة عمر على الشرح الجميل للكود كما اشكر الاخ الحبيب قنديل الصياد على تعليقه الجميل للافادة هذا كود يعمل على تسجيل اعلى و اصغر قيمة لعمود كامل Sub Test() Dim lr As Long, Lrr As Long Dim Mx As Integer, Mn As Integer, R As Integer, iCont As Integer Dim xx As Double Lrr = Feuil1.Cells(Rows.Count, 1).End(xlUp).Row For R = 1 To Lrr lr = Feuil2.Cells(Rows.Count, R).End(xlUp).Row + 1 xx = Feuil1.Cells(R, 1) iCont = WorksheetFunction.CountIf(Feuil2.Columns(R), xx) If xx <> 0 Then If iCont > 0 Then GoTo RabieCont Feuil2.Cells(lr, R) = xx Mx = WorksheetFunction.Max(Feuil2.Columns(R)) Mn = WorksheetFunction.Min(Feuil2.Columns(R)) Feuil1.Cells(R, 2) = Mx Feuil1.Cells(R, 3) = Mn RabieCont: End If Next End Sub تحياتي اعلى واصغر قيمة مسجلة في خلية.rar

السلام عليكم التحكم في عدد اعمدة اليست يكون في ملف الاستاد القدير عبد الله باقشيير بالتعديل في الكود Private Const ContColmn As Integer = 10 حيث 10 هو عدد الاعمدة اذا كان عدد الاعمدة اكثر من 13 عمود يجب ان تغيير في كود عرض البينات لكي تضهر البينات المرجة في اليست Me.ListBox1.List = Range("A5:M" & Lr).Value التغيير يكون في العمود حيث رقم العمود M هو وهو اخر عمود سيعرض في اليست 13 يمكنك تغييره الى اي عمود تشاء اما A5 هو بداية عرض البينات في اليست ارجو ان اكود اوصلت الفكرة تحياتي

لسلام عليكم حسب فهمي لطلبك جرب هذا الملف (قم تغيير قيم الخلية المتغيرة ولاحط) aa.rar

السلام عليكم الكبير كبير استاذنا القدير ملف في غاية الروعة هذه محاولة بسيطة مني ليست بروعت ملفك كنت انجزتها قبل مشاهدة ملفك تحياتي Test.rar

يسلم قلبك اخي حمادة شكرا لمرورك رمضان كريم

السلام عليكم هذا تعديل بسيط على الملف الاخير للاخ ضاحي الغريب لانه كان به خلل بسيط في كود منع التكرار وقد طلب مني ارفاق الملف الصحيح لعدم تمكنه من ذلك في الوقت الحالي ادعو له في ضهر الغيب ان يوفقه الله فيما هو فيه تحياتي للجميع مصطفي 001.rar