سليم حاصبيا

استبدل الرقم 46 بالرقم 63 او الرقم 191

بمكن ذلك Option Explicit Sub add_point() Dim i# i = 2 Do Until Cells(i, 1) = vbNullString If Right(Cells(i, 1), 1) <> Chr(46) Then Cells(i, 1) = Cells(i, 1) & Chr(46) End If i = i + 1 Loop End Sub

هذا الكود مناسب لهذه الحالة Option Explicit Sub talween() Dim my_sh As Worksheet Dim n_colore As Byte Dim i% Set my_sh = Sheets("Material.Chart2018") Dim lr%: lr = my_sh.Cells(Rows.Count, "y").End(3).Row If lr < 11 Then lr = 11 For i = 11 To lr my_sh.Cells(i, "y").Interior.ColorIndex = 0 Select Case my_sh.Cells(i, "y").Value Case Is < 0: n_colore = 6 Case Is = 0: n_colore = 3 Case Is > 0: n_colore = 43 End Select my_sh.Cells(i, "y").Interior.ColorIndex = n_colore Next End Sub

بهد اذن اخي بن علية هذا الملف الكود Option Explicit Sub divise_col_In_Tow() Dim list1 As Object Dim list2 As Object Dim arr1, arr2 Set list1 = CreateObject("System.Collections.ArrayList") Set list2 = CreateObject("System.Collections.ArrayList") Dim My_sh As Worksheet: Set My_sh = Sheets("salim") Dim lr%: lr = My_sh.Cells(Rows.Count, 1).End(3).Row Dim i% My_sh.Range("b2").Resize(1000, 2).ClearContents For i = 1 To lr Step 2 list1.Add Range("a" & i).Value list2.Add Range("a" & i + 1).Value Next i arr1 = list1.toarray: arr2 = list2.toarray My_sh.Range("b2").Resize(UBound(arr1) + 1) = _ Application.Transpose(arr1) My_sh.Range("c2").Resize(UBound(arr2) + 1) = _ Application.Transpose(arr2) list1.Clear: list2.Clear Erase arr1: Erase arr2 Set list1 = Nothing: Set list2 = Nothing End Sub الملف مرفق Salim_tow From one.xlsm

كل عامود في اكسل 2010 مثلاً بتجوي على اكثر من 10 مليون صف فلماذا تثقيل حجم الملف بأن نحعل البرنامج يفتش في 10 مليون العامود (C:C)صف ليجد لك جاحة بسيطة وهو عنوان صف معين او خلية معينة بهذا الكم الهائل من الصفوف بمكن ان تحفض هذا العدد 10 الاف مرة(100 صف مثلا) تجعل المعادلة كالاتي: =INDEX($C$3:$C$100,MATCH(F3&G3,$A$3:$A$100&$B$3:$B$100,0)

حدد الخلية (او الخلايا)المطلوب العمل عليها ثم اتيع الصورة

يجب كتابة مسيحي هكذا و ليس مسيحى

عليك بهذا الماكرو Option Explicit Sub tahweel() Dim my_rg Dim i% Dim my_st: my_st = Chr(201) Set my_rg = Sheets("Salim").Range(Range("a2"), Range("a2").End(4)) my_rg.Offset(, 2).ClearContents For i = 1 To my_rg.Rows.Count With my_rg.Cells(i) If .Value = "انثى" Then .Offset(, 2).Value = _ my_rg.Cells(i).Offset(, 1) & my_st Else .Offset(, 2).Value = _ my_rg.Cells(i).Offset(, 1) End If End With Next End Sub الملف Mouslm.xlsm

Right click on the worksheet tab and select Move or Copy.1 Select the Create a copy checkbox.2 Under Before sheet, select where you want to place the copy.3 Select OK.4

يمكنك جماية الورقة بواسطة باسوورد(وعدم السماح بتحديد خلايا معينة يهمك امرها) لان الباسوورد يؤمن الجماية من المسح والتعديل علي اي خلية

في هذا الملف الحل كما تريد حيث لا تتأثر النتيجة باختلاف ترتيب الاشهر في اي صغحة من الصفحات المعادلة ( Ctrl+Shift+Enter) في الخلية B2 =INDIRECT("GameDiv!b"&MATCH(A2,TEXT(GameDiv!$A$2:$A$13,"mmm"),0)+1)+INDIRECT("ProdDiv!b"&MATCH(A2,TEXT(ProdDiv!$A$2:$A$13,"mmm"),0)+1)+INDIRECT("UtilityDiv!b"&MATCH(A2,TEXT(UtilityDiv!$A$2:$A$13,"mmm"),0)+1) الملف SAlim_Sum.xlsx

هذا احد الحلول ترحيل بيانات Salim.xlsx

بعد اذن اخي بن علية للمزدوج =IF(ROWS($A$1:A1)>INT(COUNTA($I$4:$I$100)),"",INDEX($I$4:$I$100,2*(ROWS($A$1:A1)))) للمفرد =IF(ROWS($A$1:A1)>INT(COUNTA($I$4:$I$100)),"",INDEX($I$4:$I$100,2*(ROWS($A$1:A1))-1)) المعادلات لا توضع في العامود I

جرب هذا الملف Book1_salim.xlsx

لا اعلم اذا كان هذا المطلوب بالضبط 123_New.xlsx

الملف الذي رفعته مضروب بفيروس و قد رفض الجهاز التعامل معه لذلك ارفق لك ملفاً بديلاً فيه الجل بالتفصيل days_num.xlsx

بعد اذن أخي علي هذه المعادلة (بدون اعمدة مساعدة) (Ctrl+Shift+Enter) =INDEX($C$3:$C$11,MATCH(F3&G3,$A$3:$A$11&$B$3:$B$11,0)) الملف مرفق جمع بشرطين Salim.xlsx

يلزم هذا التعديل على الكود Option Explicit Sub sorted_liste() Dim SL1 As Object Dim xItem Dim rg As Range, c As Range Dim i As Long Dim X As Long Dim arr() Dim y Range("c1").CurrentRegion.Offset(1).ClearContents Set SL1 = CreateObject("System.Collections.ArrayList") Set rg = Sheets("salim").Cells(1).CurrentRegion For Each c In rg y = SL1.Contains(c) X = Application.CountIf(rg, c) If X > 1 And y = False Then If Not SL1.Contains(c.Value) Then SL1.Add (c.Value) End If Next arr = SL1.ToArray With Range("c2").Resize(UBound(arr) + 1) .Value = Application.Transpose(arr) .Offset(, 1).Formula = "=COUNTIF($A$1:$A$500,C2)-1" .Offset(, 1).Value = .Offset(, 1).Value End With End Sub الملف فلترة 1.xlsm

بعد اذن اخي علي بدون شرط IF ( حيث ان دالة SUM تتجاهل النصوص) هذه المعادلة (Ctrl+Shift+Enter) =SUM(1*MID(A4,ROW(INDIRECT("1:"&LEN(A4))),1))

جرب هذا الماكرو Option Explicit Sub sorted_liste() Dim SL1 As Object Dim xItem Dim rg As Range, c As Range Dim i As Long Dim X As Long Dim arr() Dim y Range("c1").CurrentRegion.ClearContents Set SL1 = CreateObject("System.Collections.ArrayList") Set rg = Sheets("salim").Cells(1).CurrentRegion For Each c In rg y = SL1.Contains(c) X = Application.CountIf(rg, c) If X > 1 And y = False Then If Not SL1.Contains(c.Value) Then SL1.Add (c.Value) End If Next arr = SL1.ToArray Range("c1").Resize(UBound(arr) + 1) = Application.Transpose(arr) End Sub الملف مرفق فلترة.xlsm

جرب الكتابة في الخلية D4 ثم حدد الخلية الصفراء و انظر الى النتيجة اذا كان ما كتبته في الخلية فيD4 موجودأ في العمود A يتم تعيئة القائمة المنسدلة(الخلية الصفراء) واذا لم يكن موجوداً تحصل على رسالة حطأ ثم فراغ في الخلية الصفراء

جرب هذا الملف 88_sali.xlsx

بعد ان احي محمد هذا الملف الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$D$4" Then Data_Val End If Application.EnableEvents = True End Sub '=============================== Sub Data_Val() Dim i%: i = 2 Dim check As Boolean Dim arr Dim MY_ST: MY_ST = [d4] check = IsError(Application.Match(MY_ST, Range("a2:a500"), 0)) If Not check Then Dim rg As Object Set rg = CreateObject("system.collections.arraylist") With rg Do Until Range("a" & i) = vbNullString If Range("a" & i) = MY_ST Then If Not .contains(Range("B" & i).Value) Then .Add Range("B" & i).Value End If i = i + 1 Loop .Sort arr = .toarray arr = Join(arr, ",") End With Range("E4") = vbNullString With Range("E4").Validation .Delete .Add xlValidateList, Formula1:=arr End With Else MsgBox "This data" & Chr(10) & MY_ST & Chr(10) & "Does'not Exits in then table", 64 With Range("E4") .Value = vbNullString .Validation.Delete End With End If End Sub الملف مرفق Carburant.xlsm

التعديل يتم باستبدال سطر واحد من الكود (ما بين النجوم) ليبدو هكذا Sub rand_num_generator() Dim i% Dim myStart%: myStart = Application.Min([N3], [O3]) Dim myEnd%: myEnd = Application.Max([N3], [O3]) Dim a() '**************************************** Range("A3").CurrentRegion.Columns(1) _ .Offset(1).ClearContents '**************************************** ReDim a(myEnd - myStart) With CreateObject("System.Collections.SortedList") For i = myStart To myEnd .Item(Rnd) = i Next i i = 0 Do Until i > .Count - 1 a(i) = .GetByIndex(i) i = i + 1 Loop End With Range("A3").Resize(UBound(a) + 1).Value = Application.Transpose(a) Erase a End Sub الكود الثاني '================================== Range("F3").CurrentRegion.Columns(1) _ .Offset(1).ClearContents '================================

استبدل المعادلة الموجودة بالتي كتبتها لك