محي الدين ابو البشر

وعليكم السلام ريما Sub test() Dim a, b, c Dim i&, ii& a = Cells(3, 2).CurrentRegion b = Cells(3, 10).CurrentRegion.Offset(2).Columns(1) ReDim c(1 To UBound(b) - 2) For i = 2 To UBound(a) For ii = 3 To UBound(a, 2) If (a(i, ii)) <> "" Then c(Application.Match(a(i, ii), b, 0)) = a(i, 2) Next Next Cells(5, 11).Resize(UBound(c)) = Application.Transpose(c) End Sub

الدرجه الأكبر.xlsx

ربما فصل الارقام عن الجمل.xlsm

Book2.xlsm

VBA? Sub test() Dim a: Dim i& a = Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) <> 0 And a(i, 1) <> "" Then If Not .exists(a(i, 1)) Then: .Add a(i, 1), "" End If Next Cells(4, 4) = Application.Small(Application.Transpose(.keys), 2) Cells(4, 5) = .Count End With End Sub Book2.xlsm

ربما مثال.xlsm

ولك مثل ما دعوت

Sub test() Dim a Dim rng As Range Dim r As Range Set rng = Application.InputBox(Title:="Please select a range", Prompt:="Select range", Type:=8) With CreateObject("VBScript.RegExp") .Global = True .Pattern = "([A-Za-z])+" For Each r In rng r.Value = Trim(.Replace(r, "")) Next End With End Sub بحيث يمكنك اختيار (النطاق) الذي تريد

ربما =COUNTIF(C2:C27,"<>0")

=IF(C3>=C2,F2,E2) والله أعلم إذا كنت قد فهمت المطلوب

Private Sub CommandButton1_Click() On Error Resume Next Dim v As Integer, lr, i ListBox1.Clear With Sheets("بيان") lr = .Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To lr If .Cells(i, 1).Offset(0, 3) <> 0 And .Cells(i, 1).Offset(0, 4) And .Cells(i, 1).Offset(0, 4) <> 0 Then If Sheets("بيان").Cells(i, 1).Offset(0, 0) >= CDate(ComboBox1.Text) Then If Sheets("بيان").Cells(i, 1).Offset(0, 1) = ComboBox2.Text Then If Sheets("بيان").Cells(i, 1).Offset(0, 0) <= CDate(ComboBox3.Text) Then ListBox1.AddItem Sheets("بيان").Cells(i, 1).Value ListBox1.List(v, 1) = Format(Sheets("بيان").Cells(i, 0).Offset(0, 0).Value, "YYYY/MM/DD") ListBox1.List(v, 2) = Sheets("بيان").Cells(i, 1).Offset(0, 1).Value ListBox1.List(v, 3) = Sheets("بيان").Cells(i, 1).Offset(0, 2).Value ListBox1.List(v, 5) = Sheets("بيان").Cells(i, 1).Offset(0, 4).Value v = v + 1 End If End If End If End If Next End Sub

الف ألف مبروك

بارك الله

الف ألف مبروك

وعليكم السلام ..تفضل أخي الكريم Book1.xlsx

ربما تنشيط ورقة عمل.xlsm

مثال توضيحي.xlsx

سلمك الله

Sub test() Dim a As Variant, lr, i, x, s, k, itm a = Sheets(1).Range("B2:B" & Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 7) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) <> 0 Then If Not .exists(a(i, 1)) Then If a(i, 7) = Sheets(2).Range("C1") Then .Add a(i, 1), a(i, 7) End If Next Sheets(2).Cells(10, 1).Resize(.Count, 2) = Application.Transpose(Application.Index(Array(.keys, .items), 0, 0)) End With End Sub أو Sub test() Dim a As Variant, lr, i, x, s, k, itm a = Sheets(1).Range("B2:B" & Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 7) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) <> 0 Then If Not .exists(a(i, 1)) Then If a(i, 7) = Sheets(2).Range("C1") Then .Add a(i, 1), "" End If Next Sheets(2).Cells(10, 1).Resize(.Count) = Application.Transpose(.keys) End With End Sub

عليكم السلام ربما Sub test() Dim a As Variant, lr, i, x, s, k, itm a = Sheets(1).Range("B2:B" & Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 3) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) <> 0 Then If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 3) Else If a(i, 3) <> "" Then .Item(a(i, 1)) = IIf(.Item(a(i, 1)) <> "", .Item(a(i, 1)) & "+" & a(i, 3), IIf(a(i, 3) <> "", a(i, 3), "")) End If End If Next itm = .items Sheets(2).Cells(2, 1).Resize(.Count, 2) = Application.Transpose(Application.Index(Array(.keys, .items), 0, 0)) End With End Sub

اضافة صفوف.xlsm

=COUNTIF(D2:N12,"<40")

F3=Round(C3/D3*E3;0)

المصنف1 (1).xlsx

ربما =VLOOKUP($B4*1,INDIRECT("'"&$C$7&"'!"&"B9:F200"),5,0)