ياسر خليل أبو البراء

أزل نسخة الإنترنت إكسبلورر الحديثة إلى أن تصل للنسخة رقم 8 ، مع اتباع تعليمات الطباعة من على الموفع

Sub Test() Dim ws As Worksheets For Each ws In Worksheets If ws.Name = "اسم الشيت المراد حذفه" Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next ws End Sub

الرابط

Sub Test() Dim delim As String Dim x As Variant Dim rRow As Integer Dim i As Integer Application.ScreenUpdating = False Range("C5:C100").ClearContents delim = Range("C2").Value x = Range("D2").Value rRow = 5 If Not IsNumeric(x) Or x = "" Then MsgBox "Enter A Number In Cell D2", vbExclamation: Exit Sub For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row Step x With Cells(rRow, "C") .NumberFormat = "@" .Value = MultiCat(Range("A" & i).Resize(x), delim) End With rRow = rRow + 1 Next i Application.ScreenUpdating = True End Sub Function MultiCat(ByRef rRng As Excel.Range, Optional ByVal sDelim As String = "") As String Dim rCell As Range For Each rCell In rRng If Not IsEmpty(rCell) Then MultiCat = MultiCat & sDelim & rCell.Text End If Next rCell MultiCat = Mid(MultiCat, Len(sDelim) + 1) End Function

k = 0 With Me.ListBox2 For i = 0 To .ListCount - 1 .AddItem .List(k, 0) = Application.WorksheetFunction.VLookup(Val(Me.ListBox1.List(i, 0)), Sheets("dalel").Range("b5:k200"), 9, 0) .List(k, 1) = Application.WorksheetFunction.VLookup(Val(Me.ListBox1.List(i, 1)), Sheets("dalel").Range("b5:k200"), 10, 0) k = k + 1 Next End With

'والتي ستحمل قيم النتائج [Temp] إعادة تعيين أبعاد المصفوفة المسماة '[Arr] وتكون بنفس أبعاد المصفوفة التي تحمل البيانات الخام والمسماة 'سنعتبر المصفوفة أشبـه بالصفـوف والأعمدة حيث الرقـم 1 يمثـل الصفـوف 'بإرجاع أكبر قيمة [UBound]بينما الرقم 2 يمثل الأعمدة ، وتقوم الكلمة 'أبعاد المصفوفة في هذه الحالة >> '------------------------------- 'البعد الأول سيكون من 1 إلى أكبر قيمة للصفوف 'البعد الثاني سيكون من 1 إلى أكبر قيمة للأعمدة ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

Sub Test() Dim strPntName As String strPntName = MatchFullNetworkPrinterName("HP LaserJet Professional P1102", True) If strPntName <> "" Then MsgBox "The Active Printer Has Been Changed Successfully!", vbOKOnly, "Tips" End Sub Function MatchFullNetworkPrinterName(ByVal strNetworkPrinterName As String, Optional ByVal blnToChange As Boolean = False) As String Dim strCurrentPrinterName As String Dim strTempPrinterName As String Dim i As Long strCurrentPrinterName = Application.ActivePrinter i = 0 Do While i < 100 strTempPrinterName = strNetworkPrinterName & " on Ne" & Format(i, "00") & ":" On Error Resume Next Application.ActivePrinter = strTempPrinterName On Error GoTo 0 If Application.ActivePrinter = strTempPrinterName Then MatchFullNetworkPrinterName = strTempPrinterName Exit Do End If i = i + 1 Loop If Not blnToChange Then Application.ActivePrinter = strCurrentPrinterName End Function

الرابط

Sub Copy_Selected_Range_As_New_Workbook() Dim a As Range, rng As Range Application.ScreenUpdating = False Set rng = Selection ActiveSheet.Copy If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData Columns.Hidden = False Rows.Hidden = False Cells.ClearContents For Each a In rng.SpecialCells(xlCellTypeVisible).Areas Range(a.Address).Value = a.Value Next a ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\YourFileName.xls", FileFormat:=56, CreateBackup:=False ActiveWorkbook.Close Application.ScreenUpdating = True End Sub

وعليكم السلام Grab Pictures Using INDEX Function.rar

بارك الله فيك أخي الغالي طلعت وجزيت خيراً على كلماتك الطيبة ، وما أنا إلا قطرة في المنتدى ، وأتعلم منك الكثير والكثير

وعليكم السلام ActivePrinter.rar

وعليكم السلام Codes Library v1.9.7.rar

الرابط

Sub RandomNames_Salim() Const startRow As Byte = 2 Const endRow As Byte = 31 Dim g(startRow To endRow), c As Integer, r As Integer Do c = Application.RandBetween(startRow, endRow) If Not g(c) Then r = r + 1 Cells(r + 1, "D").Value = Cells(c, "A").Value g(c) = True End If Loop Until r = 30 End Sub

وعليكم السلام If Arr(I, 14) Like "*" & strSearch & "*" Then استخدم السطر التالي بدلاً منه If Arr(I, 14) Like strSearch Then

Sub UpdateData() '[Ctrl + Alt + F9] يقوم الكود بعملية تحديث للمعادلات والتي تعتبر بمثابة الضغط على Application.CalculateFull End Sub جرب الكود التالي Private Sub Workbook_SheetActivate(ByVal SH As Object) Dim I As Long, WS As Worksheet With Sheet1 For Each WS In ThisWorkbook.Worksheets I = I + 1 .Range("A" & I).Value = WS.Name Next End With End Sub

أعتقد أنه للتنبيهات .. قم بالدخول عليها وقراءة المطلوب من خلالها

بارك الله فيك أخي الغالي الزباري على الموضوع الجميل يمكن تجميع مجموعة شروط من خلال اختيار Custom ثم وضع معادلة لجمع الشروط المطلوبة .. المشكلة فقط في هذه الطريقة هي عدم القدرة على التحكم في شكل الدائرة ، وأعتقد أنها لا تظهر في الطباعة (لم أجرب في الواقع) تقبل وافر تقديري واحترامي

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

وعليكم السلام أخي الكريم محمد جرب الكود التالي في حدث المصنف .. Private Sub Workbook_BeforePrint(Cancel As Boolean) Sh.Cells.Interior.ColorIndex = xlNone End Sub

وعليكم السلام أخي الكريم محمد الحمد لله أن تم المطلوب على خير .. والحمد لله الذي بنعمته تتم الصالحات

وعليكم السلام أخي الكريم محمد التحميل ليس صعب على الإطلاق .. الموقع سهل في التحميل وربما أسهل من مواقع رفع كثيرة أخرى هذه خطوات التحميل على الرابط التالي ( 3 خطوات فقط) طريقة التحميل من هنا

وعليكم السلام أخي الغالي مختار وجزيت خيراً بمثل ما دعوت لي ..مشكور على مرورك العطر بالموضوع