View Full Version : Send or data transfer multiple conditions
ahmed haleem
09-22-2016, 08:10 AM
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
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
09-25-2016, 01:03 AM
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
09-25-2016, 01:12 AM
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
09-25-2016, 01:13 AM
Sorry I'm slow in English
"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
09-25-2016, 02:28 AM
Dear mana
you are excellent
Code professionally
But there are many vibrations in the screen during the execution of the code
Do you know this?
application.screenupdating=false
ahmed haleem
09-25-2016, 02:40 AM
Yes I know
ahmed haleem
09-25-2016, 02:46 AM
Dear mana
Thank you for your creativity
thanks for following
Thanks for help
Thanks thanks thanks thanks
YasserKhalil
10-01-2016, 02:42 PM
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
10-01-2016, 02:54 PM
Thank you very much Mr. Yasser for this great explanation
YasserKhalil
10-01-2016, 11:12 PM
You're welcome. Glad I can offer some help for you
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.