تصفية تلقائية باكثر من شرط

[mustafa khatab]

السلام عليكم

المطوب ان يتم تصفية عمود البارت في جدول منفصل في حالة وجود بيانات في عمود

INDEX

 

مثل ماهو موضح فى الخلايا من 

C15:D28   

https://www10.0zz0.com/2024/02/14/05/574362972.png

 

 

 

تصفية تلقائية.xlsx

تم تعديل فبراير 14, 2024 بواسطه mustafa khatab

[محمد هشام.]

10 ساعات مضت, mustafa khatab said:

المطوب ان يتم تصفية عمود البارت في جدول منفصل في حالة وجود بيانات في عمود

وعليكم السلام ورحمة الله تعالى وبركاته

لم افهم مادا تقصد بتصفية البيانات في جدول منفصل لاكن على العموم  للحصول على النتيجة الظاهرة في الصورة اعلى يكيفي استخدام الكود التالي 

Option Explicit

Public Sub TransposeData()
Dim Cpt() As Variant, I As Long, J As Long, k As Long, rng As Variant

Dim WS As Worksheet: Set WS = Worksheets("Sheet1")
  Application.ScreenUpdating = False
    rng = WS.[C6:O10].Value2
    For I = 2 To UBound(rng)
        For J = 2 To UBound(rng, 2) Step 2
            If rng(I, J) > 0 Then
                ReDim Preserve Cpt(2, k + 1)
                Cpt(0, k) = rng(I, 1)
                Cpt(1, k) = rng(I, J)
                k = k + 1
            End If
        Next J
    Next I
        If k > 0 Then
        WS.Range("C15:D" & Rows.Count).ClearContents
        WS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt)
        End If
 Application.ScreenUpdating = True 
End Sub

 ولوضعها في جدول يمكنك التعديل على الكود على الشكل التالي 

هدا مثال لنسخ البيانات على ورقة 2 

Option Explicit
Public Sub TransposeData2()
Dim WS As Worksheet, desWS As Worksheet, rng As Variant
Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String
Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2")
Application.ScreenUpdating = False
    rng = WS.[C6:O10].Value2
    For I = 2 To UBound(rng)
        For J = 2 To UBound(rng, 2) Step 2
            If rng(I, J) > 0 Then
                ReDim Preserve Cpt(2, k + 1)
                Cpt(0, k) = rng(I, 1)
                Cpt(1, k) = rng(I, J)
                k = k + 1
            End If
        Next J
    Next I
        If k > 0 Then
desWS.Range("C15:D" & Rows.Count).ClearContents
desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt)
'اظافة الجدول
loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address
If desWS.ListObjects.Count <> 0 Then Exit Sub
desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX")
desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _
"Table1"
End If
 Application.ScreenUpdating = True
End Sub

 

تصفية تلقائية V2.xlsb

تم تعديل فبراير 14, 2024 بواسطه محمد هشام.
اظافة مثال لنسخ على ورقة2

[mustafa khatab]

شكرا اخى لكن بعد اضافة بعض البيانات والضغط على نسخ لم يتم التحديث 

 

 

[محمد هشام.]

ربما لم تنتبه للكود اذا اردت الاشتغال على ورقة 2  قم بتعديل هذا السطر لان البيانات يتم جلبها من ورقة 1 

14 ساعات مضت, محمد هشام. said:

 ولوضعها في جدول يمكنك التعديل على الكود على الشكل التالي 

هدا مثال لنسخ البيانات على ورقة 2

Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2")
الى
Set WS = Worksheets("Sheet2"): Set desWS = Worksheets("Sheet2")

 او تعديله بالكامل بالشكل التالي 

Option Explicit
Public Sub TransposeData2()
Dim desWS As Worksheet, rng As Variant
Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String
Set desWS = Worksheets("Sheet2")
Application.ScreenUpdating = False
    rng = desWS.[C6:O10].Value2
    For I = 2 To UBound(rng)
        For J = 2 To UBound(rng, 2) Step 2
            If rng(I, J) > 0 Then
                ReDim Preserve Cpt(2, k + 1)
                Cpt(0, k) = rng(I, 1)
                Cpt(1, k) = rng(I, J)
                k = k + 1
            End If
        Next J
    Next I
        If k > 0 Then
desWS.Range("C15:D" & Rows.Count).ClearContents
desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt)
'اظافة الجدول
loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address
If desWS.ListObjects.Count <> 0 Then Exit Sub
desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX")
desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _
"Table1"
End If
 Application.ScreenUpdating = True
End Sub