Send or data transfer multiple conditions

[ahmed haleem]

How is the transfer or send data from the worksheet to multiple worksheets but several conditions
1. The name of the sheet = customer name
2. Heads of different table in sheets, which will send data
3. Use event worksheet (change) of sheet1
Sales 1.xlsm

[mana]

I will try again.

Option Explicit


Private Sub Worksheet_Deactivate()
    Dim ws As Worksheet
    Dim r As Range
    Dim i As Long, m


    With Range("a1").CurrentRegion
        For Each ws In Worksheets
            If ws.Name <> Me.Name Then
                ws.UsedRange.Columns("a:g").Offset(1).ClearContents
                .AutoFilter 6, ws.Name
                If .Columns("a").SpecialCells(xlCellTypeVisible).Count > 1 Then
                    Set r = Intersect(.Cells, .Offset(1))
                    For i = 1 To 5
                        r.Columns(i).Copy
                        m = Application.Match(r.Cells(0, i), ws.Rows(1), 0)
                        If IsNumeric(m) Then
                            ws.Cells(2, m).PasteSpecial xlPasteValues
                        End If
                    Next
                End If
                .AutoFilter
            End If
        Next
    End With


End Sub

[ahmed haleem]

hi mana
Thanks for following
I do not want to work autofilter data
Can you look at the names of the sheets and column F
I am working on this code can see it

Private Sub Worksheet_Change(ByVal Target As Range)

 If Target.Column = 3 Then
        Set ws = ActiveSheet
        Set r = Cells(Target.Row, 1).Resize(, 6)
        Set tgt = Sheets(Target.Value).Cells(Rows.Count, 1).End(xlUp)(2)
        tgt.Resize(, 6).Value = r.Value
    End If


End Sub

I want to modify this code after his experience and look at all the sheets

[ahmed haleem]

hi mana
Thank you very much to continue.
I do not want the work autofilter.
You can modify this code

Private Sub Worksheet_Change(ByVal Target As Range)

 If Target.Column = 6 Then
        Set ws = ActiveSheet
        Set r = Cells(Target.Row, 1).Resize(, 6)
        Set tgt = Sheets(Target.Value).Cells(Rows.Count, 1).End(xlUp)(2)
        tgt.Resize(, 6).Value = r.Value
    End If


End Sub

[ahmed haleem]

Sorry I'm slow in English

[mana]

"change event" is inconvenience in this case.
please try this.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cc As Range, c As Range
    Dim ws As Worksheet, r As Long, i As Long, m
    
    On Error Resume Next
    Set cc = Intersect(Columns(6), Target)
    On Error GoTo 0
    If cc Is Nothing Then Exit Sub
    
    For Each c In cc
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(c.Value)
        On Error GoTo 0
        If Not ws Is Nothing Then
            r = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
            For i = 1 To 5
                m = Application.Match(Cells(1, i), ws.Rows(1), 0)
                If IsNumeric(m) Then
                    c.EntireRow.Cells(i).Copy
                    ws.Cells(r, m).PasteSpecial xlPasteValues
                End If
            Next
        End If
    Next
 
End Sub

[ahmed haleem]

Dear mana
you are excellent
Code professionally
But there are many vibrations in the screen during the execution of the code

[mana]

Do you know this?

application.screenupdating=false

[ahmed haleem]

Yes I know

[ahmed haleem]

Dear mana
Thank you for your creativity
thanks for following
Thanks for help
Thanks thanks thanks thanks

[YasserKhalil]

Hello Mr. Ahmed
I have explained the code in your native language to be able to get it easilt

Private Sub Worksheet_Change(ByVal Target As Range)
'الكود ينفذ في حدث تغير ورقة العمل
'---------------------------------
    'تعريف المتغيرات
    Dim cc As Range, c As Range
    Dim ws As Worksheet, r As Long, i As Long, m

    'تعطيل تحديث الشاشة لتسريع عمل الكود
    Application.ScreenUpdating = False

        'تحديد النطاق أو العمود الذي سيقع عليه التغير
        'ووضع السطر بين جملتين لتفادي الخطأ في حالة حدوث خطأ
        On Error Resume Next
            Set cc = Intersect(Columns(6), Target)
        On Error GoTo 0

        'إذا لم يتم إحداث تغير في العمود السادس ألا وهو عمود العملاء
        'يتم الخروج من الإجراء الفرعي
        If cc Is Nothing Then Exit Sub

        'حلقة تكرارية لكل خلية من خلايا النطاق
        For Each c In cc

            'تفريغ الذاكرة من المتغير والذي سيخصص ليحمل قيمة ورقة العمل
            Set ws = Nothing

            'تعيين ورقة العمل بقيمة الخلية أي أن المتغير سيكون لورقة العمل
            '[Customer1] التي هي قيمة الخلية ، فمثلاً لو كانت قيمة الخلية تساوي
            '[Customer1] سيشير لورقة العمل المسماة [ws] فإن المتغير المسمى
            'ووضع بين جملتين لتفادي الخطأ في حالة عدم وجود ورقة العمل
            On Error Resume Next
                Set ws = Worksheets(c.Value)
            On Error GoTo 0

            'جملة لاختبار وجود ورقة العمل ، لأن نفي النفي إثبات
            'وتستخدم للتأكد من وجود ورقة العمل [Nothing] وكلمة [Not] وهنا استخدمت كلمة
            'إذا وجدت ورقة العمل المعنية يتم تنفيذ الأسطر التالية
            If Not ws Is Nothing Then

                'تعيين آخر صف في ورقة العمل المعنية بناءً على العمود الأول
                r = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

                'حلقة تكرارية للأعمدة من 1 إلى 5 أي من العمود الأول للعمود الخامس
                For i = 1 To 5

                    'حيث يتم [Match] سطر لمعرفة العنوان من خلال استخدام الدالة
                    'البحث عن العنوان في الصف الأول من ورقة العمل المعنية
                    'ويقوم بإرجاع رقم العمود الذي يحمل نفس العنوان بالضبط
                    m = Application.Match(Cells(1, i), ws.Rows(1), 0)

                    'إذا كانت القيمة التي تم إرجاعها من السطر السابق رقمية فإن
                    If IsNumeric(m) Then

                        'يتم نسخ الخلية حسب العمود أي لو كانت الحلقة الأولى
                        'تساوي واحد وبالتالي يتم نسخ [I] فإن قيمة العداد
                        'الخلية في العمودالأول في صف الخلية التي تتم فيها الحلقة
                        c.EntireRow.Cells(i).Copy

                        'يتم لصق الخلية المنسوخة إلى الورقة المعنية
                        'إلى آخر صف فيها وفي العمود الذي يطابق العنوان
                        ws.Cells(r, m).PasteSpecial xlPasteValues

                    'رقمية [m] نهاية جملة شرط أن قيمة المتغير
                    End If

                'الانتقال للحلقة التكرارية التالية أي العمود التالي
                Next i

            'نهاية جملة شرط التأكد من وجود ورقة العمل
            End If

        'الانتقال للحلقة التكرارية التالية لخلايا العمود السادس
        Next c

    'إلغاء خاصية النسخ والقص
    Application.CutCopyMode = False

    'تفعيل تحديث الشاشة بعد الانتهاء من تنفيذ الكود
    Application.ScreenUpdating = True
End Sub

Hope this will help you

[ahmed haleem]

Thank you very much Mr. Yasser for this great explanation

[YasserKhalil]

You're welcome. Glad I can offer some help for you