الـعيدروس

السلام عليكم ارجو منك ارفاق مثال عن السؤال الثاني كي تتضح الفكرة أكثر تحياتي

السلام عليكم إذهب إلى ==> رايت كليك ثم تنسيق خلايا الرقم إستخدام فاصل الألف ( , )

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

السلام عليكم تفضل هذا الكود يدرج في حدث الفورم Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Const GWL_STYLE = -16 Const WS_SYSMENU = &H80000 Private Sub UserForm_Initialize() Dim hWnd As Long, lStyle As Long If Val(Application.Version) >= 9 Then hWnd = FindWindow("ThunderDFrame", Me.Caption) Else hWnd = FindWindow("ThunderXFrame", Me.Caption) End If lStyle = GetWindowLong(hWnd, GWL_STYLE) SetWindowLong hWnd, GWL_STYLE, (lStyle And Not WS_SYSMENU) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Cancel = (CloseMode = 0) End Sub قبل تفعيل الفورم لاتنسى تضيف زر لإخفاء الفورم مثلا ليبل هكذا Private Sub Label1_Click() ME.Hide End Sub

السلام عليكم استخدم هذا الكود بدلا من حدث الصفحة لسبب حدث الصفحة يسبب بطئ في حال البيانات كثيرة Sub THOEEL() For Each T_ALI In Range("A2:H50") T_ALI.Value = UCase(T_ALI.Value) Next End Sub

السلام عليكم هذا لتنسيق التاريخ Private Sub ComboBox1_Change() Me.ComboBox.Value = Format(Me.ComboBox.Value, "yyyy/mm/dd") End Sub

السلام عليكم الاخ الفاضل samycalls السموحه منك على تأخري في الرد بالنسبة لزيادة الاعمدة في حالة البحث حاولت ولم تزبط معي وبالنسبة للبحث بمعيارين الملف المرفق الاخير من قبلك ملخبط شويات ان شاء الله بعمل عليه حالياً وارفقه تقبل نحياتي وشكري

جرب هكذا Sub A() On Error Resume Next Dim S As Worksheet Dim X& Z = 3 For Each S In Application.Worksheets If S.Name = "ورقة1" Then GoTo 0 X = S.Cells(1000, 7).End(xlUp).Row Cells(Z + 1, 6).Value = S.Cells(X, 7).Value Z = Z + 5 0: Next End Sub

السلام عليكم ==== اظهار المجموع مجرد كتابة كلمة البحث تغير اتجاه البيانات ==== تفضل المرفق تقسيط السلع_ALIDROOS.rar

السلام عليكم الاخ الفاضل skyblue الطلب غامض جرب المرفق ان شاء الله اكون وفقت book_ALI.rar

تفضل في المرفق السبت_والاحد_ALI_C.rar

السلام عليكم جرب الكود بعد تعديل بسيط ان شاء الله يمشي حاله معاك Sub Button1_Click() On Error Resume Next prompt = "هل حقا تريد مسح البيانات ؟.انتبه لا يوجد تراجع عن المسح!!" Command_buttons = vbYesNo + VbMsgBoxRt1Reading Title = "تحذير. انتبه" project = MsgBox(prompt, Command_buttons, Title) If project = vbYes Then Range("A7:Z100").Select Selection.SpecialCells(xlCellTypeConstants, 23).ClearContents Range("A1").Select End If End Sub

يمكن تجنب الاوراق التي فيها بيانات بحلقة تكرارية لعدة اوراق مثلا For s = 1 To Sheets.Count If Sheets(s).Name = "ورقة2" Then Exit Sub If Sheets(s).Name = "ورقة3" Then Exit Sub Next يصير الكود بهذا الشكل Private Sub Workbook_SheetActivate(ByVal Sh As Object) For s = 1 To Sheets.Count If Sheets(s).Name = "ورقة2" Then Exit Sub If Sheets(s).Name = "ورقة3" Then Exit Sub Next For Each Sh In ActiveWorkbook.Worksheets S_ALI = S_ALI & "," & Sh.Name Next Sh Range("A1").Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=S_ALI End With End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("A1")) Is Nothing Then Worksheets(Target.Value).Select End If End Sub

فعلا استاذ عبدالله كما تفضلت وبرضه في حدث Thisworkbook بهذه الاحداث بيكون افضل كي يتسنى الرجوع لاي ورقة تريد من الورقة المختارة Private Sub Workbook_SheetActivate(ByVal Sh As Object) For Each Sh In ActiveWorkbook.Worksheets S_ALI = S_ALI & "," & Sh.Name Next Sh Range("A1").Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=S_ALI End With End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("A1")) Is Nothing Then Worksheets(Target.Value).Select End If End Sub

السلام عليكم هذا الكود تحطه في حدث THISWORKBOOK Private Sub Workbook_Open() For Each sh In ActiveWorkbook.Worksheets S_ALI = S_ALI & "," & sh.Name Next sh Range("A1").Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=S_ALI End With End Sub وهذا في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("A1")) Is Nothing Then Worksheets(Target.Value).Select End If End Sub وهذا المرفق SH_DATA.rar

السلام عليكم الاخ الفاضل محمد تميرك استعن بهذا الكود تم عمله لطلب احدهم في منتدى اخر Option Explicit Const C_A As String = "ALL_SH" Sub C_ALIDROOS() On Error Resume Next Application.ScreenUpdating = False Dim SH As Worksheet Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = C_A With ActiveSheet .Range("A1:B1").Borders.Color = 5 .Range("A1:B1").Font.Bold = True .Range("A1").Value = "أسماء الصفحات" .Range("B1").Value = "لينك الصفحات" .Columns("A:A").EntireColumn.AutoFit .Columns("B:B").EntireColumn.AutoFit .Columns("C:C").ColumnWidth = 1 End With For Each SH In ThisWorkbook.Worksheets If SH.Name = C_A Then GoTo 1 With ActiveSheet.Columns(1).Rows(65536).End(xlUp) .Offset(1, 0) = SH.Name .Offset(1, 1).FormulaR1C1 = "=HYPERLINK(""#'"" & RC[-1] & ""'!A1"", ""اذهب للورقة"")" End With SH.Range("A1").Formula = "=HYPERLINK(""#ALL_SH!A1"",""ALL_SH"")" 1 Next SH Application.ScreenUpdating = True End Sub واضن ورقة التاريخ لاداعي لها لان الكود بيضيف ورقة جديدة وعليها اسماء الصفحات وعليها لينك للذهاب لكل صفحة على حده ولينك في خلية A1 في كل صفحة للرجوع لصفحة الفهرس

لم انتبه للطلب الثاني هذا الكود لزيادة اعمدة الليست بوكس الى اي عدد تريده Private Sub UserForm_Initialize() On Error Resume Next Me.ListBox1.Clear Dim M_ALI As Range With ورقة1 Set M_ALI = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Resize(, 30) End With With Me.ListBox1 .ColumnCount = M_ALI.Columns.Count .List = M_ALI.Value End With End Sub وهذ المرفق LIST_ALI.rar

السلام عليكم الاخ الفاضل skyblue انت كاتب "ترحيل اجمالي الورقة 2 هنا " وهكذا باقي السطور لذا ارجو منك توضيح الطلب او بمعنى ماهي الاليه التي تريدها ارجو التوضيح اذا تكرمت

السلام عليكم الاخ الفاضل samycalls السموحه منك على التأخير في الرد وذلك لانشغالي بعد كتابة كلمة البحث اضغط انتر تفضل المرفق امل ان يفي بالغرض والسلام عليكم تقسيط السلع_ALI_C.rar

السلام عليكم تم عمل المطلوب على الليست بوكس ان شاء الله ينال استحسانك اطلع على المرفق تحياتي تقسيط السلع_ALI_C.rar

السلام عليكم بعد اذن الاستاذ الحبيب عبدالله المجرب بعض التعديلات البسيطه ان شاء الله يزبط معاك جرب المرفق Classeur1_ALI.rar

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

السلام عليكم تفضل المرفق كود للاستاذ القدير بن عليه لطباعة الكل تم اضافة عمود لمسلسل الارقام في شيت ورقة1 Copy of Xl0000004_B_A.rar

السلام عليكم بعد اذن الاستاذ الحبيب طارق اضفت شرط للكود في حال الخلية فارغة يعتمد القيمة "=" Sub Bouton1_QuandClic() Sheets("All2").Select Range("s1:bw2800").ClearContents Range("G3").Select With Feuil1 If IsEmpty(.[B2]) Then .[B2] = "=" Sheets("bd").Range("A1:be2800").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("con").Range("a1:be2"), CopyToRange:=Range("s1:bw2800"), Unique:=False .[B2] = Empty End With End Sub

السلام عليكم تفضل المرفق جرب وابلغنى بالنتائج ان شاء الله يكون اسرع نوع ما تحياتي تقسيط السلع_ALI_B.rar