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

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


MGS

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

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

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

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

12.rar

تم تعديل بواسطه 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

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

السلام عليكم

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

تبحث عن الاسم

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

هذا هو الكود


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

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

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

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

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

تحياتي

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

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

alidross

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

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

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

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

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

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

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

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

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

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

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

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

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

دمتم بود

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

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

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

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

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

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

ألسلام عليكم

الاخ القاضل new4a

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

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

عن طريق فورم

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

تفضل

FORM_alidroos.rar

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

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

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

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

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

تحياتى

سعد عابد

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information