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
17138

[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