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

بارك الله

ربما تصفية.xlsm

عسى Book1+.xlsm

وعليكم السلام والرحمة ممكن أن ترينا شكل النتائج التي تريد؟

أعتقد ان هناك حالات لم توضحها مثلا : ماذا اذا كان الرقم غير 5 وغير موجود فيالقائمة أذا كانت الخلية غير فارغة وفيها اسم موجود في القائمة وكتبت 5 ماذا تريد أن يحصل!!؟ .......

عسى Book1.xlsm

Book1.xlsmالأولى

تفضل يا رعاك الله sief122.xlsm

بارك الله وكل عام وأنتم بألف خير

وعليكم السلام ربط خليتين.xlsm

استبد الكود بـ Private Sub TextBox1_Change() ActiveSheet.Unprotect "2212" Application.ScreenUpdating = False ActiveSheet.ListObjects("data").Range.AutoFilter Field:=12, Criteria1:="*" & TextBox1 & "*", Operator:=xlFilterValues Application.ScreenUpdating = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) ActiveSheet.Protect "2212" End Sub

جبر المعادلة.xlsمعادلات أو Sub Test() Range("H2").Resize(Range(Cells(2, 7), Cells(2, 7).End(xlDown)).Cells.Count).FormulaR1C1 = "=CEILING(RC[-1],5)" End Sub

الخليةA1 NEXT.xlsm

RAFAT.xlsm

Just for fun Sub test2() Range("E1") = Range("C2") & " بتاريخ " & Range("C1") End Sub

هكذا؟ Sub test() Dim r As Range Dim a Dim k&, c&, z& k = 7 Application.ScreenUpdating = False With Sheets("تقرير الوردية اليومي") a = .Cells(4, 2).Resize(, 13) For Each r In .Range("B5:B" & Cells(Rows.Count, 2).Row).SpecialCells(2, 23).Areas .Cells(r(1).Row, 2).Offset(1).Resize(r.Rows.Count, .Cells(r(1).Row, Columns.Count).End(xlToLeft).Column - 1).Copy z = Sheets("شيت مجمع").Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets("شيت مجمع").Cells(z, k).PasteSpecial Paste:=xlPasteValues k = k + 12 c = r.Rows.Count - 1 Next Sheets("شيت مجمع").Cells(z, 1).Resize(c, 6) = Application.Index(a, 1, Array(2, 4, 6, 8, 10, 13)) End With Application.ScreenUpdating = True End Sub

ترحيل السلة.xlsm

وعليكم السلام ممكن خيار آخر Sub test() Dim a, temp a = Cells(1, 1).CurrentRegion temp = Application.Transpose(Filter(Evaluate("transpose(if((" & Columns(5).Address & "<>""" & """)*(" & Columns(5).Address & "<>""" _ & "Invoice No" & """),row(1:" & Rows.Count & ")))"), False, 0)) Cells(1, 1).CurrentRegion.Offset(2).ClearContents a = Application.Index(a, temp, [{1, 2, 3, 4, 5, 6}]) With Sheets("sales") .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(a), UBound(a, 2)) = a End With End Sub

B2=LEFT(A2,FIND("-",A2)-1)

تفضل Private Sub Worksheet_Change(ByVal Target As Range) Dim a, No, w Dim i& a = Sheets("ÞÇÚÏÉ ÇáÈíÇäÇÊ").Cells(1).CurrentRegion Application.ScreenUpdating = False If Not Intersect(Target, Cells(1, 9)) Is Nothing Then Me.Range(Cells(2, 2), Cells(2, 2).End(-4121).Cells).Offset(, -1).Resize(, 4).ClearContents With CreateObject("scripting.dictionary") For i = 3 To UBound(a) If a(i, 1) = Target.Value Then If Not .Exists(a(i, 1) & a(i, 3)) Then .Add (a(i, 1) & a(i, 3)), Array(a(i, 3), a(i, 4), a(i, 5), a(i, 6)) Else w = .Item(a(i, 1) & a(i, 3)) w(0) = w(0): w(1) = w(1) + a(i, 4) w(2) = w(2) + a(i, 5): w(3) = w(3) + a(i, 6) .Item(a(i, 1) & a(i, 3)) = w End If End If Next Me.Cells(2, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0) End With End If Application.ScreenUpdating = True End Sub عملياً فقط تغيير Me.Range(Cells(2, 2), Cells(2, 2).End(-4121).Cells).Offset(, -1).Resize(, 4).ClearContents

بالإذن ربما Sub test() Dim r As Range Dim a Dim k&, c& k = 7 Application.ScreenUpdating = False With Sheets("تقرير الوردية اليومي") a = .Cells(4, 2).Resize(, 13) For Each r In .Range("B5:B" & Cells(Rows.Count, 2).Row).SpecialCells(2, 23).Areas .Cells(r(1).Row, 2).Offset(1).Resize(r.Rows.Count, .Cells(r(1).Row, Columns.Count).End(xlToLeft).Column - 1).Copy Sheets("شيت مجمع").Cells(2, k).PasteSpecial Paste:=xlPasteValues k = k + 12 c = r.Rows.Count - 1 Next Sheets("شيت مجمع").Cells(2, 1).Resize(c, 6) = Application.Index(a, 1, Array(2, 4, 6, 8, 10, 13)) End With Application.ScreenUpdating = True End Sub

بارك الله

مثال (1).xlsx

بارك الله

كود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("A4:A3000")) Is Nothing Then With Target .Offset(, 5).Value = Format(Date, "YYYY/MM/DD") .Offset(, 6).Value = Format(Time, "hh: mm") End With End If End Sub