اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by حسين مامون,

الردود الموصى بها

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

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

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

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

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

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

 

تم تعديل بواسطه الـعيدروس
  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

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

رابط هذا التعليق
شارك

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

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

من الممكن ان يكون مفيد لك اخى العيدروس ... فانا لا افقه شيء فى بحر ال 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

 

  • Like 1
رابط هذا التعليق
شارك

تم بنجاح

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

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

رابط هذا التعليق
شارك

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

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

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

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

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

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

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

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

 

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information