نسخ الصفوف التى تحتوى على كلمه محدده

[MGS]

بسم الله العلى القدير

كيف يمكن نسخ الصفوف التى تحتوى على كلمه معينه الى شيتات معينه فى الملف

مثال ( لو وجدت كلمه القاهرة فى صف يتم نسخه الى ملف شيت القاهرة واذا وجدت مره اخرى فى البيانات المجمعه يتم نسخها ايضاه وهكذا )

12.rar

تم تعديل أكتوبر 25, 2011 بواسطه MGS

[يحيى حسين]

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

أحي جرب هذا الكود

Sub CopyToPges()

Dim LR As Long, ws As Worksheet, Mws As Worksheet

Set Mws = Sheets("sheet1")

LR = Mws.Range("A" & Rows.Count).End(xlUp).Row

For Each ws In Sheets

    If ws.Name <> "Sheet1" Then

	    With Mws.Range("A1:D" & LR)

		    .AutoFilter 1, ws.Name

	    End With

    Mws.Range("A1").CurrentRegion.Copy

    ws.Range("A1").PasteSpecial xlPasteValues

    End If

Next ws

Mws.Range("A1").AutoFilter

Application.CutCopyMode = False

End Sub

[MGS]

بارك الله فيك اخى الفاضل

هل يمكن تحديد الأسم المراد نسخه والمكان المراد الأرسال فيه ( يعنى لو وجدت حلوان او الجيزه يتم النسخ الى القاهره )

[الـعيدروس]

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

13.rar

[MGS]

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

[هشام شلبى]

السلام عليكم

========

الاخ الحبيب يحيى ماشاء الله تبارك الله

نحمد الله على سلامتكم

[MGS]

هل من مجيب

[MGS]

هل يمكن تحديد الأسم المراد نسخه والمكان المراد الأرسال فيه ( يعنى لو وجدت حلوان او الجيزه يتم النسخ الى القاهره )

[الـعيدروس]

السلام عليكم

تم عمل كود كالتالي :

تبحث عن الاسم

وبعدها تكتب اسم الورقة المراد لصق البيانات فيه

هذا هو الكود

Sub Find_alidroos()

Dim rng As Range

Dim sh As Worksheet

Dim sh1 As Worksheet

Dim go  As String

Dim ali As String

  On Error Resume Next

go = Application.InputBox("ادخل كلمة البحث", "")

  If go = "False" Or go = vbNullString Then Exit Sub

  With Range("A2:A25000")

Set rng = .Find(go, , LookIn:=xlValues, lookat:=xlWhole)

	 If rng = True Then

	   MsgBox "غير موجود الاسم في قاعدة البيانات او تأكد من حالة الأحرف"

	 Exit Sub

	 Else

   ali = Application.InputBox("ادخل اسم الورقة المراد لصق البيانات فيها", "")

If ali = "False" Or ali = vbNullString Then Exit Sub

    rng.Offset(0, 0).Resize(1, 4).Select

   Selection.Copy

  Set sh1 = Sheets(ali)

	   Application.ScreenUpdating = False

	 Application.EnableEvents = False

  sh1.Select

	    ish = Range("a15000").End(xlUp).Row + 1

    Range("a" & ish).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

  End If

   End With

   MsgBox "تمت عملية نسخ النتيجة بنجاح ", vbInformation, ""

  Application.CutCopyMode = False

  Application.ScreenUpdating = True

Application.EnableEvents = True

End Sub

وهذا المرفق

ان شاء الله يفيدك

14_alidroos.rar

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

ابا نصار

لم اجرب الملف ولكن قرات الكود

عمل احترافي تسلم يدك

الم اقلك نشاطك ملحوظ وان شاء الله نراك هكذا على طول ومن حسن الى احسن

ابواحمد

[الـعيدروس]

هذا ماتعلمناه منكم استاذي عبدالله المجرب

وفقك الله

[الـعيدروس]

السلام عليكم

الاخ الفاضل MGS

وهذا حل اخر

نفس الكود وعليه تعديلات طفيفة

الاسم المراد نسخة انقر على الزر صندوق البحث

اشر على الصف المطلوب نسخة

وصندوق الورقة اشر على اي خلية فيها اسم الورقة المعنية

وموافق وراح ينسخة للورقة المختارة

هذا الكود

Sub Find1_alidroos()

Dim rng As Range

Dim sh As Worksheet

Dim sh1 As Worksheet

Dim go  As String

Dim ali As String

    On Error Resume Next

	    Application.DisplayAlerts = False

		    Set rng = Application.InputBox(Prompt:= _

			    "ادخل كلمة البحث تحديد بالماوس", _

				    Title:="سبحان الله وبحمدة سبحان الله العظيم", Type:=8)

		   On Error GoTo 0

		  Application.DisplayAlerts = True

	    If rng Is Nothing Then

	 Exit Sub

	    Else

   ali = Application.InputBox("ادخل اسم الورقة المراد لصق البيانات فيها", "")

If ali = "False" Or ali = vbNullString Then Exit Sub

  rng.Select

    Set sh1 = Sheets(ali)

	 Application.ScreenUpdating = False

	 Application.EnableEvents = False

	   sh1.Select

	    ish = Range("a15000").End(xlUp).Row + 1

	    rng.Offset(0, 0).Resize(1, 4).Copy Destination:=sh1.Range("a" & ish)

   MsgBox "تمت عملية نسخ النتيجة بنجاح ", vbInformation, ""

   End If

  Application.CutCopyMode = False

  Application.ScreenUpdating = True

Application.EnableEvents = True

End Sub

وهذا مرفق

15_alidroos.rar

[خالد القدس]

السلام عليكم

فعلا عمل احترافي مميز أستاذ أبا نصار

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

[الـعيدروس]

الاخ الاستاذ خالد القدس

اسعدني مرورك وفقك الله

[MGS]

بارك الله فيكم اهل المنتدى الكرام

[الـعيدروس]

ان شاء الله تكون زبطت الاكواد معك

موفق خلينا نشوفك في ثنايا هذا المنتدى

وسوف تستفيد الكثير ان كنت تريد ان تتعلم

تحياتي

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

اخي المبدع " الصبور " ابو نصار

اهنئك .... ماشاء الله ... ماشاء الله

الحقيقة .... متعة وابداع

وفقك الله

ابو الحارث

[naderwatfa]

أعجبني الكود أخي

alidross

تسلم الأيادي المبدعة

سمحت لنفسي بإضافة بسيطة

قد تكون مفيدة لبعض الأخوة

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

أو يمكنك بكود آخر النسخ مع مسح البيانات الأصلية

مع إضافة أكواد الأستاذ خبور الخاصة بحذف أو إضافة صفوف

كما يمكنك تغيير أسماء الأوراق كلها دون تأثير على الأكواد

ترحيل بمسح أو بدون.rar

[الـعيدروس]

الاخ الحبيب ياسر الحافظ

اسعدني مرورك العطر

الاخ الفاضل نادر جزاك الله خير على الاضافات القيمة

[الشهابي]

أكواد جميلة ورائعة إخواني جزاكم الله خير

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

تسلم وتشكر اخي العزيز نادر على الاضافة الجميلة

وفقك الله ... والشكر موصول الى العزيز ابو نصار

ابو الحارث

[يوسف عطا]

أكواد ولا أروع

يمكن الإستفادة بها فى عمليات الترحيل المختلفة

أنا عن نفسى سوف أستفيد بها فى ترحيل الناجح والراسب من شيت النتيجة إلى شيتات الناجحين والراسبين

الف شكر أساتذتنا الكرام

دمتم بود

[ابو القبطان]

إخواني الاحباء .. العيدروس ونادر

ماذا نضيف للسيد كود حتى ينسخ كل ما يتوافق مع المعيار ، بمعنى لو تكرر المعيار او كلمة البحث في اكثر من صف ضمن الجدول ونريد نسخ كل الصفوف

تقبلوا وافر شكري

أخوكم : حسن علي

[الـعيدروس]

ألسلام عليكم

الاخ القاضل new4a

منور الموضوع طلبك رخيص

تفضل ولاكن دلعنا الشغلة شويات

عن طريق فورم

وماتكتشفه ومايعجبك خليها فكاهه

تفضل

FORM_alidroos.rar

[saad abed]

حبيبى ابو نصار

ايه الحلاوة دى ده بالمصرى شغل على مياه بيضاء

بمعنى لا يستطيع احد انتقاضه او انتقاصه

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

تحياتى

سعد عابد