كود فرز و نقل بيانات بشرط

[ehabaf2]

السلام عليكم الاستاذ الكرام

محتاج كود فرز و نقل بيانات العميل من شيت الى شيت اخر بشرط اذا كان من العملاء الموجودين بالشركة ينقل الى مكان محدد فى الشيت و اذا كان من غير عملاء الشركة ينقل فى مكان اخر

مرفق شيت للتوضيح

نقل البيانات بشرط.xlsx

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

عليكم السلام

عسى أمون قد فهمت الموضوع صح

جرب هذا

Sub test()
    Dim dic1 As Object: Dim dic2 As Object
    Dim a, b, w, xx
    Dim i&
    a = Sheets("فودا").Cells(1).CurrentRegion
    b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2))
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
        If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then
            If Not dic1.exists(a(i, 3)) Then
                dic1.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7))
            Else
                w = dic1.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic1.Item(a(i, 3)) = w
            End If
        Else
            If Not dic2.exists(a(i, 3)) Then
                dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7))
            Else
                w = dic2.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic2.Item(a(i, 3)) = w
            End If
        End If
    Next
    With Sheets("رحل")
        Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)).ClearContents
        Range(.Cells(3, 8), .Cells(3, 11).End(xlDown)).ClearContents
        .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0)
        .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0)
    End With
End Sub

 

[ehabaf2]

استاذنا الفاضل محي الدين ابو البشر

الحمد لله و الشكر لله الكود يعمل بشكل رائع و هو المطلوب و لكن يقرأ اسم العميل من صفحة فودا

هل ممكن يقرا اسم العميل من صفحة قاعدة العملاء لان ده الاسم المعروف لدينا

الف شكر لحضرتك

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

هكذا؟

Sub test()
    Dim dic1 As Object: Dim dic2 As Object
    Dim a, b, w, bb
    Dim i&
    a = Sheets("فودا").Cells(1).CurrentRegion
    b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2))
    bb = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(1))
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
        If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then
            If Not dic1.exists(a(i, 3)) Then
                dic1.Add a(i, 3), Array(a(i, 3), bb(Application.Match(a(i, 3), b, 0)), a(i, 7))
            Else
                w = dic1.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic1.Item(a(i, 3)) = w
            End If
        Else
            If Not dic2.exists(a(i, 3)) Then
                dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7))
            Else
                w = dic2.Item(a(i, 3))
                w(2) = w(2) + a(i, 7)
                dic2.Item(a(i, 3)) = w
            End If
        End If
    Next
    With Sheets("رحل")
      Union(Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)), Range(.Cells(3, 8), .Cells(3, 11).End(xlDown))).ClearContents
        .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0)
        .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0)
    End With
End Sub

 

[ehabaf2]

السلام عليكم استاذنا الفاضل محي الدين ابو البشر

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

الحمد لله الكود يعمل بشكل رائع و هو المطلوب 

اكرر شكرى لحضرتك

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

الحمد لله 

بارك الله