تعديل على كود ترحيل البيانات من شيت لآخر

[a.sayed.atta]

السلام عليكم و رحمه الله و بركاته

اخوانى الاعزاء

ارجو التعديل على الملف المرفق بحيت لا يتم تكرار البيانات المرحله فى كل مرة نضغط فيها على زر الترحيل 

عند الضغط على زر الترحيل اكثر من مرة يقوم بترحيل البيانات من الشيت الرئيسى اكثر من مرة

ارجو ايجاد حل لهذه المشكلة

test.xlsm

[الـعيدروس]

السلام عليكم

امسح البيانات بعد ترحيلها من صفحة الرئيسية

Sub trheel()
Dim Rng As Range
Dim cl As Range, i As Integer
Set Rng = Range("G3:G" & [G10000].End(xlUp).Row)
For i = 2 To 41
For Each cl In Rng
If cl <> "" Then
If cl.Value = Sheets(i).Name Then
cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1)
End If
End If
Next
Next
If Rng.Rows.Count > 7 Then Rng.Offset(0, -6).Resize(, 7).ClearContents
Set Rng = Nothing
End Sub

 

تم تعديل نوفمبر 9, 2019 بواسطه الـعيدروس

[a.sayed.atta]

مشكور اخى العيدروس

اضافة جميلة جدا

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

test.xlsm

[الـعيدروس]

السلام عليكم

بالامكان التحقق من القيم اذا رحلت سابقاً لايرحلها

كالتالي

Sub trheel()
Dim Cl As Range, i As Integer
For i = 2 To 41
For Each Cl In Range("G3:G" & [G10000].End(xlUp).Row)
If Not Ch(Cl, i) Then
If Cl.Value = Sheets(i).Name Then
Cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1)
End If
End If
Next
Next
End Sub
Private Function Ch(Cl As Range, i) As Boolean
If Application.CountIfs(Sheets(i).Range("A3:A" & 1500), _
Range("A" & Cl.Row), Sheets(i).Range("B3:B" & 1500), _
Range("B" & Cl.Row), Sheets(i).Range("C3:C" & 1500), Range("C" & Cl.Row), _
Sheets(i).Range("F3:F" & 1500), Range("F" & Cl.Row)) = 1 Then Ch = True
End Function

 

[a.sayed.atta]

مشكور اخى العيدروس

و لكن لم يعمل بالشكل المطلوب

و ذلك لانه اذا تكررت قيم صف فى صف اخر لا يرحلها

و فى هذا العمل سوف تتكرر القيم فى اكثر من صف

مشكور مرة اخرى اخى على هذا المجهود و اسف على كثرة مطالبى

[a.sayed.atta]

بعد التصفح فى الموقع فى بعض الموضوعات التى تخص الترحيل

تم التوصل الى هذا الملف وهو اقرب ما يكون لما اريد

من الممكن ان يكون مفيد لك اخى العيدروس ... فانا لا افقه شيء فى بحر ال VBA

 

أجندة محامى أخر وضع2.xlsm

[الـعيدروس]

السلام عليكم

استخدام عمود وسيط ممكن هذا التعديل مثل الملف

Sub trheel()
Dim Cl As Range, i As Integer
For i = 2 To 41
For Each Cl In Range("G3:G" & [G10000].End(xlUp).Row)
If Not Ch(Cl) Then
If Cl.Value = Sheets(i).Name Then
Cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1)
Cells(Cl.Row, "XFD") = "OK"
End If
End If
Next
Next
End Sub
Private Function Ch(Cl As Range) As Boolean
If Cells(Cl.Row, "XFD") = "OK" Then Ch = True
End Function

 

[a.sayed.atta]

تم بنجاح

مشكور اخى العيدروس على هذا المجهود .. لقد توصلت الى الكود المراد 👍

و فى الاخير اقوم بشكر جميع اعضاء المنتدى على هذا العمل الرائع

[a.sayed.atta]

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

اخى حسين مامون و اخوتى الافاضل

لي طلب يشبه ما قمت به من حل رائع قى هذه المشاركه

معى ورقه عمل اقوم فيها بالترحيل من شيت رئيسى الى مجموعه شيتات مختلفة حسب اسم العميل

المشكله .... فى كل مرة نقووم بالضغط على زر الترحيل يقوم بتكرار ترحيل كل البيانات التى قم تم ترحيلها مسبقا

المطلوب ..... اريد تعديل الكود ليقوم بتجاهل كل البياتات المرحله سابقا و ترحيل كل ما اضيف حديثا بعد اخر عمليه ترحيل .. 

من فضلك لا تكرر نفس الطلب فى مشاركة اخرى -والا ستحذف المشاركة نهائياً

test.xlsm

[حسين مامون]

تم تعديل الكود جرب ربما يكون ما تريد

Sub trheel()

Dim cl As Range, i As Integer

For i = 2 To 41
For Each cl In Range("G3:G" & [G10000].End(xlUp).Row)
If cl.Value = Sheets(i).Name Then
If cl.Offset(0, -6).Resize(1, 7).Interior.Color = &HC0FFFF Then GoTo 1
cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1)
cl.Offset(0, -6).Resize(1, 7).Interior.Color = &HC0FFFF
End If
1: Next
Next
End Sub

 

[a.sayed.atta]

مشكور اخى  واستاذى حسين مأمون -وبالفعل هو ده الحل المطلوب

بارك الله فيك وزادك الله من فضله ووسع الله فى رزقك