مشكلة فى كود الترحيل عند فلترة مصدر البيانات

[ابوحمزه المصرى]

  السلام عليكم وحمة الله وبركاته .. أخوانى اعضاء المنتدى العملاق "أوفيسنا" يوجد كود بالملف المرفق لترحيل البيانات من شيت RawData الى شيت ClientSheet حسب ثلاثة خلايا هم S1,S2,S3 فى شيت ClientSheet  وبعد استخدامى للكود يوجد مشكلتان .. الأولى لو عملت فلتر لعميل فى شيت  RawData ثم اختيار عميل آخر فى ClientSheet ستجد ان البيانات لا ترحل بالكامل وبعد استخدامى للشيت وزيادة البيانات فعملية الترحيل لا تتم بالكامل فى هذه الحالة فقط فانا مرتبط بمراجعة الفلتره فى RawData  قبل اختيار العميل فى ClientSheet  .. المشكلة الثانية أن كود الزوم المرتبط بشيت ClientSheet فى خلايا S1,S2,S3 لا يعمل بعد تصميم كود الترحيل فما الحل كشف حساب جديد.rar

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

الأخ الفاضل صلاح

إليك الملف التالي لعله يكون المطلوب ..

أما بالنسبة لكود الزوم فيعمل معي بدون أي مشاكل في الأعمدة 5 و 6 و 7 ...

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet
    Dim strCrt As String
    Dim I As Long, X As Long
    X = 6
    Set WS = RawData: Set SH = ClientSheet
    strCrt = SH.Range("T1").Value
    Application.ScreenUpdating = False
        SH.Range("A6:R135").ClearContents
        With WS
            .AutoFilterMode = False
            For I = 6 To .Cells(4000, 1).End(xlUp).Row
                If .Cells(I, "S").Value = strCrt Then
                    .Range(.Cells(I, "A"), .Cells(I, "R")).Copy
                    SH.Range("A" & X).PasteSpecial xlPasteValues
                    X = X + 1
                End If
            Next I
            
            .Range("A5:R5").AutoFilter Field:=4, Criteria1:=.Range("S1").Value
        End With
        SH.Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Function FilterCriteria(Rng As Range) As String
    Dim Filter As String
    Filter = ""
    On Error GoTo Finish
    With Rng.Parent.AutoFilter
        If Intersect(Rng, .Range) Is Nothing Then GoTo Finish
        With .Filters(Rng.Column - .Range.Column + 1)
            If Not .On Then GoTo Finish
            Filter = .Criteria1
            Select Case .Operator
                Case xlAnd
                    Filter = Filter & " AND " & .Criteria2
                Case xlOr
                    Filter = Filter & " OR " & .Criteria2
            End Select
        End With
    End With
Finish:
    FilterCriteria = Filter
End Function

تقبل تحياتي

كشف حساب جديد.rar

[ابوحمزه المصرى]

بارك الله فيك اخى ابو البراء وجزاك كل خير ممكن شرح الكود مع اضافة الغاء كافة الفلتره عند اختيار عميل فى شيت ClientSheet لأنه لو لغيت الفلتر يدوى بيرجع تانى بعد اختيار العميل فى ClientSheet   أما الزووم انا اقصد الزووم الخاص بالشيت ClientSheet فى خلايا S1,S2,S3

تم تعديل أبريل 28, 2015 بواسطه صلاح الدين الأيوبى

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

جرب الكود بهذا الشكل لإلغاء عملية الفلترة عند الترحيل ..

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet
    Dim strCrt As String
    Dim I As Long, X As Long
    X = 6
    Set WS = RawData: Set SH = ClientSheet
    strCrt = SH.Range("T1").Value
    Application.ScreenUpdating = False
        SH.Range("A6:R135").ClearContents
        With WS
            .AutoFilterMode = False
            For I = 6 To .Cells(4000, 1).End(xlUp).Row
                If .Cells(I, "S").Value = strCrt Then
                    .Range(.Cells(I, "A"), .Cells(I, "R")).Copy
                    SH.Range("A" & X).PasteSpecial xlPasteValues
                    X = X + 1
                End If
            Next I
        End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

وللزوم قم بتغيير الكود لديك بهذا الكود

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Address = "$S$1" Or Target.Address = "$S$2" Or Target.Address = "$S$3" Then
        ActiveWindow.Zoom = 120
    Else
        ActiveWindow.Zoom = 80
    End If
End Sub

تقبل تحياتي

[ابوحمزه المصرى]

جميل بارك الله فيك اخى ياسر بس طلب اخير بالنسبه للفتر اتلغى خاالص ... كنت اقصد الغاء الفلتره فقط .. لكن اريد الفلتر جاهز للاستخدام  .. ارجوا ان اكون اوضحت المطلوب بشكل مناسب

[ابوحمزه المصرى]

الحمد لله مَن الله على و تشجعت وتجرأت وتقدمت للتعديل فتوصلت الى هذة النتيجة الطويله التيله ارجوا التدخل السريع للانقاذ واختصار هذا التهور منى اخى الفاضل

Sub Tarhil()

    Dim WS As Worksheet, SH As Worksheet

    Dim strCrt As String

    Dim I As Long, X As Long

    X = 6

    Set WS = RawData: Set SH = ClientSheet

    strCrt = SH.Range("T1").Value

    Application.ScreenUpdating = False

        SH.Range("A6:R135").ClearContents

        With WS

            .Range("$A$5:$R$4001").AutoFilter Field:=1

            .Range("$A$5:$R$4001").AutoFilter Field:=2

            .Range("$A$5:$R$4001").AutoFilter Field:=3

            .Range("$A$5:$R$4001").AutoFilter Field:=4

            .Range("$A$5:$R$4001").AutoFilter Field:=5

            .Range("$A$5:$R$4001").AutoFilter Field:=6

            .Range("$A$5:$R$4001").AutoFilter Field:=7

            .Range("$A$5:$R$4001").AutoFilter Field:=8

            .Range("$A$5:$R$4001").AutoFilter Field:=9

            .Range("$A$5:$R$4001").AutoFilter Field:=10

            .Range("$A$5:$R$4001").AutoFilter Field:=11

            .Range("$A$5:$R$4001").AutoFilter Field:=12

            .Range("$A$5:$R$4001").AutoFilter Field:=13

            .Range("$A$5:$R$4001").AutoFilter Field:=14

            .Range("$A$5:$R$4001").AutoFilter Field:=15

            .Range("$A$5:$R$4001").AutoFilter Field:=16

            .Range("$A$5:$R$4001").AutoFilter Field:=17

            .Range("$A$5:$R$4001").AutoFilter Field:=18

            For I = 6 To .Cells(4000, 1).End(xlUp).Row

                If .Cells(I, "S").Value = strCrt Then

                    .Range(.Cells(I, "A"), .Cells(I, "R")).Copy

                    SH.Range("A" & X).PasteSpecial xlPasteValues

                    X = X + 1

                End If

            Next I

        End With

    Application.CutCopyMode = False

    Application.ScreenUpdating = True

End Sub

تم تعديل أبريل 28, 2015 بواسطه صلاح الدين الأيوبى

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

أخي الكريم يرجى وضع الأكواد بين أقواس الأكواد لتظهر بشكل منضبط

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet
    Dim strCrt As String
    Dim I As Long, X As Long
    X = 6
    Set WS = RawData: Set SH = ClientSheet
    strCrt = SH.Range("T1").Value
    Application.ScreenUpdating = False
        SH.Range("A6:R135").ClearContents
        With WS
            .AutoFilterMode = False
            For I = 6 To .Cells(4000, 1).End(xlUp).Row
                If .Cells(I, "S").Value = strCrt Then
                    .Range(.Cells(I, "A"), .Cells(I, "R")).Copy
                    SH.Range("A" & X).PasteSpecial xlPasteValues
                    X = X + 1
                End If
            Next I
            
            .Range("A5:R5").AutoFilter
        End With
        SH.Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

زي كدا

جرب الكود بهذا الشكل النهائي .. وإن شاء الله يكون أدى المطلوب

[ابوحمزه المصرى]

اشكرك اخى الفاضل ياسر خليل ربنا يعزك بس كنت عايز اسأل  الكود بين اى نوع اقواس بالضبط ليظهر بهذا الشكل و هناك زر يظهر لى على اسفل الشاشة الرد على مشاركة مقتبسه وعند الضغط عليه لا يتغير اى شئ 

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

هذا الشكل <> وتصبح على خير يا كبير

السلام عليكم

[ابوحمزه المصرى]

شكراً لك على عطائك الدائم وأرجو أن لا أكون اثقلت عليك أخى الفاضل ابو البراء .. فى حفظ الله

تم تعديل أبريل 29, 2015 بواسطه صلاح الدين الأيوبى