ترحيل بالفلترة

[طائع]

المطوب بالمرفق

الرجاء المساعدة

 

__ ___ ______.rar

[طائع]

للرفع

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

الأخ الكريم طائع

الملف ليس له علاقة بعملية الفلترة

اطلع على الملف التالي وشوف النتائج ...

Sub YasserKhalil()
    Dim I As Long, X As Long, Y As Long
    X = 3: Y = 7
    Application.ScreenUpdating = False
    With Sheets("Sheet2")
        .Range("B7:D17").ClearContents
        If .Range("A1").Value = 1 Or .Range("A1").Value = 2 Or .Range("A1").Value = 3 Then
            I = .Range("A1").Value
            Sheets("data" & I).Activate
            .Range("B" & Y).Resize(, 3).Value = Cells(109, X).Resize(, 3).Value
            .Range("B" & Y + 1).Resize(, 3).Value = Cells(109, X + 4).Resize(, 3).Value
            .Range("B" & Y + 2).Resize(, 3).Value = Cells(109, X + 8).Resize(, 3).Value
            .Range("B" & Y + 3).Resize(, 3).Value = Cells(109, X + 12).Resize(, 3).Value
            .Range("B" & Y + 6).Resize(, 3).Value = Cells(109, X + 16).Resize(, 3).Value
            .Range("B" & Y + 7).Resize(, 3).Value = Cells(109, X + 20).Resize(, 3).Value
            .Range("B" & Y + 8).Resize(, 3).Value = Cells(109, X + 24).Resize(, 3).Value
            .Range("B" & Y + 9).Resize(, 3).Value = Cells(109, X + 28).Resize(, 3).Value
            .Range("B" & Y + 10).Resize(, 3).Value = Cells(109, X + 32).Resize(, 3).Value
        Else
            I = .Range("A1").Value
            Sheets("data" & I).Activate
            For X = 3 To 43 Step 4
                .Range("B" & Y).Resize(, 3).Value = Cells(109, X).Resize(, 3).Value
                Y = Y + 1
            Next X
        End If
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub

تم إضافة هذا الكود

أرجو أن يكون المطلوب

Ehsaa.rar