كود لنقل البيانات

[شمس الثورة]

السلام عليكم ابحث عن كود عن طريقه تنقل البيانات فقط من الشيت الى كشف المنقولين دون حذف اى صف من ورقة الشيت بمعنى كود ينقل البيانات فقط وينقل البيانات كاملة وجعلكم الله فى عون المحتاج فعند كتاية منقول يتم نقل البيانات فقط الى صفحة المنقول ويترك الصف فارغ

المنقول.rar

[عبد الفتاح كيرة]

كود

Sub Macro4()

'

' Macro4 ماكرو by kemas

'

Dim mycl As Range

Dim myrng As Range

'

 Application.ScreenUpdating = False

 Range("newrng").ClearContents

    Range("I2").Select

    Sheets("الشيت").Range("A1:N41").AdvancedFilter Action:=xlFilterCopy, _

        CriteriaRange:=Range("منقول!Criteria"), CopyToRange:=Range("A7:N7"), _

        Unique:=False

    ActiveWindow.LargeScroll ToRight:=1

    Range("A7").Select

    Set myrng = Sheets("الشيت").Range("n1:n41")

    For Each mycl In myrng

        If mycl = "منقول" Then

            mycl.EntireRow.ClearContents

        End If

    Next mycl

    Sheets("منقول").Select

    Application.ScreenUpdating = True


End Sub

مرفق

المنقول-kemas.rar

[شمس الثورة]

السلام عليكم الخىkemas عمل رائع ولكن بعد ترحيل البانات عند الضغط على زر الترحيل يتم حذف البيانات التى كانت موجوده فانا اريد عندما لكتب منقول فى الشيت واضغط زر الترحيل يتم نقل البيانات مثلما فعلت انت ولكن لا يمسح البانات التى رحلت مسبقا

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

[عبدالله المجرب]

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

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

اخي شمس

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

المنقول-kemas.rar

[ياسر الحافظ]

الاخوة / الاساتذة : كيماس " ابو عمر " - عبد الله المجرب " ابو احمد "

جزاكم الله كل الخير على هذه الاكواد الرائعة

احببت ان اشارك معكم في هذا الموضوع ( من باب المشاركة والتنوع )

كود يقوم بالترحيل ويجمع المنقولين في الورقة ( منقول ) ولكنه يحذف الاصل من الورقة ( الشيت )

عسى ان ينتفع به اخونا العزيز " شمس الثورة "

وفقكم الله

ياسر الحافظ

تجميع المنقولين مع حذف الاصل.rar

[يحيى حسين]

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

على نفس ملف الأخ عبدالله المجرب

جرب الكود التالي

Sub Test()

Dim wsF As Worksheet, wsT As Worksheet


Set wsF = Sheets("الشيت")


Set wsT = Sheets("منقول")


With wsF.Range("a1").CurrentRegion

    .AutoFilter Field:=14, Criteria1:=wsT.Range("b2").Value

    .Copy wsT.Range("a7")

    .AutoFilter

End With

End Sub

[MAHMOUD ALI YOUSSEF]

السلام عليكم

تحية خاصة لكل من الاستاذة الكبار

يحي حسين

ياسر الحافظ

ابو احمد

كيماس

مع حفظ الالقاب

علي مجهوداتهم الرائعة التي استفدت منها كثرا

وشكرا

تم تعديل يوليو 23, 2011 بواسطه MAHMOUDFOXMAM

[شمس الثورة]

السلام عليكم

تحية خاصة لكل من الاستاذة الكبار يحي حسين ياسر الحافظ ابو احمد كيماس

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

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

[الحسامي]

السلام عليكم

بارك الله فيكم اخوتي في الله

احببت ان اشارك معكم في هذا الموضوع ( من باب المشاركة والتنوع )

Dim c As Range

For Each c In Sheet1.Range("case")

If c.Value = "منقول" Then

 Z = Z + 1

lstrow = Sheet4.Range("b20000").End(xlUp).Row + 1

Sheet4.Range(Sheet4.Cells(lstrow, "b"), Sheet4.Cells(lstrow, "ag")) = _

Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")).Value

Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")) = Empty

Sheet4.Cells(lstrow, "a") = Z:

End If

Next c

المنقول.rar

[شمس الثورة]

مبدع استاذنا الحسامى

ولى بعض الاسئلة

هل يمكن شرح مبسط لهذا الكود

ثانيا اذا احببت تغير المدى الذى تنقل منه البيانات بمعنى مثلا لا يتم نقل المسلسل مثلا فماذا اغير فى الكود

[الحسامي]

السلام عليكم

مدى الكود( عموديا) هنا متغير اي مهما كانت طول القائمة سيتم حسابها فقد تم استخدام نطاق مرن اسميناه "case"

اما مدى الكود بشكل افقي فيقوم باخذ البيانات ابتداءاً من الخلية الثانية بدون المتسلسل ولو اردنا الترحيل بدون المسلسل فقط امسح السطر

Sheet4.Cells(lstrow, "a") = Z:

وهنا سيقوم بالترحيل بدون المسلسل والكود مكون من جمل تكرار مع استخدام اداة الشرط "If" واستخدام تعاريف الخلايا فقط وهنا الكود بشكله النهائي

Dim c As Range

For Each c In Sheet1.Range("case")

If c.Value = "منقول" Then

lstrow = Sheet4.Range("b20000").End(xlUp).Row + 1

Sheet4.Range(Sheet4.Cells(lstrow, "b"), Sheet4.Cells(lstrow, "ag")) = _

Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")).Value

Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")) = Empty

End If

Next c

[عبد الفتاح كيرة]

و هذا تعديل للكود الذى أوردته

مع الشكر لأستاذنا الحسامى

Sub Macro4()

'

' Macro4 ماكرو by kemas

Dim LastR As Long

Dim mycl As Range

Dim myrng As Range

'

 Application.ScreenUpdating = False

        Set myrng = Sheets("الشيت").Range("n1:n41")

    For Each mycl In myrng

    LastR = Sheets("منقول").Range("a" & Rows.Count).End(xlUp).Row + 1

        If mycl = "منقول" Then

            mycl.EntireRow.Cut Sheets("منقول").Range("a" & LastR)

        End If

    Next mycl

    Sheets("منقول").Select

    Application.ScreenUpdating = True


End Sub

[ياسر الحافظ]

استاذنا الحسامي - استاذنا كيماس

روائع ... جزاكم الله كل الخير

ملاحظة : عذرا استاذنا الحسامي قمت برفع مرفقك الى موضوع اكواد منفصلة تهم الجميع لللاستاذ محمد يحياوي

وفقـــــــــــــــــــــــــــــــــــــــــــــــــــــكم الله

ياسر الحافظ

[ياسر الحافظ]

عذرا

[الحسامي]

السلام عليكم

اخي ياسر

افعل ما يحلو لك للفائدة ومجهود تشكر عليه

وبارك الله فيك اخي كيماس كود ممتاز ورائع

[saad abed]

اخوانى اساتذة المنتدى

كلما تعددت الحلول واختلفت طرق الوصول للهدف

كلما تعلم المبتدئين امثالى كيف تكون الحلول بطرق مختلفة

شكرا لكم

تحياتى

سعد عابد

[شمس الثورة]

اخوانى اساتذة المنتدى كيماس والحسامى

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

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

[شمس الثورة]

اخوانى اساتذة المنتدى كيماس والحسامى

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

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

0

[الحسامي]

السلام عليكم

بالنسبة لحذف الصف فهو كان ما طلب انا فهمت من الطلب بانك هكذا تريد

واتوقع جميع الاخوة هكذا فهموا

اذا لم يكن المطلوب مسح البيانات فقد امسح هذا السطر

Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")) = Empty

Dim c As Range

For Each c In Sheet1.Range("case")

If c.Value = "منقول" Then

lstrow = Sheet4.Range("b20000").End(xlUp).Row + 1

Sheet4.Range(Sheet4.Cells(lstrow, "b"), Sheet4.Cells(lstrow, "ag")) = _

Sheet1.Range(Sheet1.Cells(c.Row, "b"), Sheet1.Cells(c.Row, "ag")).Value

End If

Next c

[احمد فضيله]

الاخوه الأعزاء

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

[احمد فضيله]

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

بعد اذن الاخوة الأعزاء

فقط لإثراء الموضوع

الاخ / شمس الثورة

تفضل هذا المرفق

و الله الموفق والمستعان

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

المنقول HaNcOcK.rar

[احمد فضيله]

و تفضل يا أخي هذا المرفق

و هو حل بطريقة أخري

فقط اكتب منقول ثم انتقل لشيت منقول

و الله الموفق والمستعان

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

المنقول HaNcOcK 2.rar

[ياسر الحافظ]

اخي وصديقي الاستاذ احمد فضيلة " HaNcOk " :

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

اعتقد ان اخونا " شمس الثورة " اصبح لديه خيارات واسعة ورائعة ... كلنا استفدنا كثيرا من هذا التنوع في الردود

تشكر

وفقك الله

ياسر الحافظ " ابو الحارث "

[احمد فضيله]

اخي وصديقي الاستاذ احمد فضيلة " HaNcOk " :

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

اعتقد ان اخونا " شمس الثورة " اصبح لديه خيارات واسعة ورائعة ... كلنا استفدنا كثيرا من هذا التنوع في الردود

تشكر

وفقك الله

ياسر الحافظ " ابو الحارث "

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

أخي الفاضل الاستاذ / ياسر الحافظ " ابو الحارث "

بالفعل التنوع في الردود يفيدنا جميعاً و يعطينا أفكار مختلفة

بارك الله فيك و جزاك الله كل خير على دعائك

و شكراً لك على كلماتك الطيبة

و الله الموفق والمستعان

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