ارجو المساعدة في ترحيل البيانات

[aburajai]

اخواني الاحباء 

 

ارجو المساعدة في ترحيل بيانات من الصفحة 1 من جدول

 

الى جدول في صفحة2 و صفحة 3

 

مع الشكر الجزيل

 

المثال داخل الملف المرفق

aburaji9.rar

[أبو حنــــين]

السلام عليكم

انسخ هذا الكود في الصفحة رقم 1

Private Sub Worksheet_Change(ByVal Target As Range)

    Last_Row = ورقة2.Cells(Rows.Count, "D").End(xlUp).Row + 1
    LastRow = ورقة3.Cells(Rows.Count, "D").End(xlUp).Row + 1
If Not IsEmpty(Target) Then
If Target.Column = 3 Then
    ورقة2.Cells(Last_Row, 4) = Target.Value
Else
If Target.Column = 4 Then
    ورقة3.Cells(LastRow, 4) = Target.Value
End If
End If
End If

End Sub

[aburajai]

اخي ابو حنين

 

بارك الله فيك

 

هذا الكود يرحل اخر خليه في السطر

 

انا اريد يرحل كامل الشطر 

يعني  اربع خانات

 

شكرا لتعاونك

[أبو حنــــين]

استعمل هذه الكود

Private Sub Worksheet_Change(ByVal Target As Range)

    Last_Row = ورقة2.Cells(Rows.Count, "D").End(xlUp).Row + 1
    LastRow = ورقة3.Cells(Rows.Count, "D").End(xlUp).Row + 1
If Not IsEmpty(Target) Then
If Target.Column = 3 Then
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 3)).Copy ورقة2.Cells(Last_Row, 1)
Else
If Target.Column = 4 Then
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 4)).Copy ورقة3.Cells(LastRow, 1)
End If
End If
End If

End Sub

[aburajai]

 

استعمل هذه الكود

Private Sub Worksheet_Change(ByVal Target As Range)

    Last_Row = ورقة2.Cells(Rows.Count, "D").End(xlUp).Row + 1
    LastRow = ورقة3.Cells(Rows.Count, "D").End(xlUp).Row + 1
If Not IsEmpty(Target) Then
If Target.Column = 3 Then
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 3)).Copy ورقة2.Cells(Last_Row, 1)
Else
If Target.Column = 4 Then
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 4)).Copy ورقة3.Cells(LastRow, 1)
End If
End If
End If

End Sub

 

السلام عليكم ورحمة الله

 

اخي ابو حنين

وضعت الكود الجديد ولم يعمل

 

اخي حبذا لو غلبتك قليلا فسامحني

 

ان تقوم بوضعه في الملف المرفق

والتاكد منه

وارفاق الملف بعد التعديل

 

فلعل الخطا يكون مني

 

شاكرا تعاونك وفي ميزان حسناتك ان شاء الله

 

 

تم تعديل ديسمبر 17, 2013 بواسطه aburajai

[أبو حنــــين]

السلام عليكم

لا يوجد مرفق

الخطأ في تسمية الاوراق

Private Sub Worksheet_Change(ByVal Target As Range)

    Last_Row = sheet2.Cells(Rows.Count, "D").End(xlUp).Row + 1
    LastRow = sheet3.Cells(Rows.Count, "D").End(xlUp).Row + 1
If Not IsEmpty(Target) Then
If Target.Column = 3 Then
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 3)).Copy sheet2.Cells(Last_Row, 1)
Else
If Target.Column = 4 Then
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 4)).Copy sheet3.Cells(LastRow, 1)
End If
End If
End If

End Sub

[aburajai]

اخي ابو حنين

 

ملف الاكسل مرفق في المشاركة الاولى

بارك الله فيك

 

لم يعمل الكود عندي

 

للتذكير : انا اعمل على اكسل 2003

تم تعديل ديسمبر 17, 2013 بواسطه aburajai

[أبو حنــــين]

المرفق بعد التعديل

aburaji9.rar

[aburajai]

بارك الله فيك ابو حنين وجزاك الله خيرا

 

هناك مشكلة ظهرت عندي

 

وهي عندما اقوم باستعما خاصية الالصاق في سطر الصفحة الاولى

 

لا يقوم الكود بترحيل البيانات الى الصفحة2 و 3

 

اما اذا قمت بالكتابة في كل خلية على حدة

 

يقوم الكود بالترحيل

 

 

فهل من الممكن حل هذه المشكلة

 

جزاك الله خيرا

[عطاء الله]

السلام عليكم أخي أبو رجاء

بعد إذن الأخ أبو حنين

هذه طريقة بواسطة المعادلات صحيحة 100/100حسب فهمي لك

ataa.rar

[aburajai]

السلام عليكم

اخي عطاء

 

الملف لا يفتح

 

فيه مشكلةارجو عمل 

 

المعادلات على ملف جديد 2003 اكسل

 

مع الشكر

[عطاء الله]

تفضل لعله المطلوب

عطاء.rar