كود الترحيل الى صفحات

[إبراهيم ابوليله]

ارجو المساعده من اهل الخبره

كود الترحيل الى صفحات.rar

[طارق محمود]

السلام عليكم

الأخ العزيز

الخليه B4 بها رقم سيارة

أين ذلك في ورقة البيانات

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

بالخلية P124:P126 يعني 39/4 فلابد من استبدال / بإشارة أخري لأنها غير مقبولة في مكونات اسم الورقة

الأفضل أن ترسل مثال كامل

وتعمل الخطوات يدويا علي إحدي السيارات

[إبراهيم ابوليله]

الاخ طارق

تحيه طيبه وبعد

اسف لهذا الخطأ

ولكن المقصود برقم السياره هو ( الشركه ) العمود G

[إبراهيم ابوليله]

الاخوه الافاضل

ارجو المساعده

[طارق محمود]

السلام عليكم

أخي العزيز

هذا هو الكود

Sub Macro1()

'TAREQ MAHMOUD


nm = [A4]: comp = Format([B4], "#"): fr_D = ">=" & Format([C4], "000"): to_D = "<=" & Format([D4], "000")

For i = 1 To Sheets.Count

	If Sheets(i).Name = comp Then

		Reply = MsgBox("الورقة " & comp & " موجودة من قبل " & Chr(10) & " هل تريد اعاده النسخ لنفس الصفحه", vbYesNo)

		If Reply = 6 Then GoTo 10

		Exit Sub

	End If

Next i


Sheets.Add After:=Sheets(Sheets.Count)

ActiveSheet.Name = comp


10 Sheets("بيانات").Select

	LR = [V10000].End(xlUp).Row

	ActiveSheet.AutoFilterMode = False

	With ActiveSheet.Range("$A$3:$V$" & LR - 2)

		.AutoFilter Field:=1, Criteria1:=fr_D, Operator:=xlAnd, Criteria2:=to_D

		.AutoFilter Field:=6, Criteria1:=nm

		.AutoFilter Field:=7, Criteria1:=comp

	End With



	Sheets(comp).Select

	[A1:W500].FillRight

	Sheets("بيانات").Range("A1:V" & LR).Copy ([A1])

	Columns("A:V").EntireColumn.AutoFit

	Application.CutCopyMode = False

	ActiveSheet.DisplayRightToLeft = True


End Sub

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

كود الترحيل الى صفحات.rar

[إبراهيم ابوليله]

جميل اخ طارق بارك الله فيك

كود ولا اروع من ذلك

ولكن اخ طارق هل يمكن عمل الاتى

تثبيت كلا من

الاسم --- التاريخ --- التااريخ

وتعديد اسماء الشركات

كما فى المرفق

كود الترحيل الى صفحات.rar

[طارق محمود]

السلام عليكم

أخي الكريم

عدل الكود ليصبح كالتالي

Sub Macro1()

'TAREQ MAHMOUD

mySht = ActiveSheet.Name

nm = [A4]: fr_D = ">=" & Format([B4], "000"): to_D = "<=" & Format([C4], "000")

LC = [IV4].End(xlToLeft).Column

For c = 4 To LC

comp = Format(Sheets(mySht).Cells(4, c), "#")



	For i = 1 To Sheets.Count

		If Sheets(i).Name = comp Then

			Reply = MsgBox("الورقة " & comp & " موجودة من قبل " & Chr(10) & " هل تريد اعاده النسخ لنفس الصفحه", vbYesNo)

			If Reply = 6 Then GoTo 10

		Exit Sub

		End If

	Next i


	Sheets.Add After:=Sheets(Sheets.Count)

	ActiveSheet.Name = comp


10	 Sheets("بيانات").Select

	LR = [V10000].End(xlUp).Row

	ActiveSheet.AutoFilterMode = False

	With ActiveSheet.Range("$A$3:$V$" & LR - 2)

		.AutoFilter Field:=1, Criteria1:=fr_D, Operator:=xlAnd, Criteria2:=to_D

		.AutoFilter Field:=6, Criteria1:=nm

		.AutoFilter Field:=7, Criteria1:=comp

	End With



	Sheets(comp).Select

	[A1:W500].FillRight

	Sheets("بيانات").Range("A1:V" & LR).Copy ([A1])

	Columns("A:V").EntireColumn.AutoFit

	Application.CutCopyMode = False

	ActiveSheet.DisplayRightToLeft = True

Next c

MsgBox ("تم إضافة عدد " & LC - 3 & " ورقات")

End Sub

أو تفضل المرفق

كود الترحيل الى صفحات2.rar

[mhrrd]

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

جزاك الله خيرا استاذ طارق

في ترحبل الناجحين والدوز الثاني والراسبين

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

[إبراهيم ابوليله]

الاخ طارق

عمل رائع بارك الله فيك

وشكرا جزيلا لك

[طارق محمود]

السلام عليكم

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

تاذ طارق

جزاك الله خيرا استاذ طارق

في ترحبل الناجحين والدوز الثاني والراسبين

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

أخي العزيز

سرعة الكود لأن البيانات قليلة

ولكنه بالطبع يمكن طبيقه في ترحيل الناجحين / الراسبين

[mhrrd]

السلام عليكم

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

تاذ طارق

جزاك الله خيرا استاذ طارق

في ترحبل الناجحين والدوز الثاني والراسبين

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

أخي العزيز

سرعة الكود لأن البيانات قليلة

ولكنه بالطبع يمكن طبيقه في ترحيل الناجحين / الراسبين

لو نكرمت غير الكود ليناسب ترحيل الناححين والراسبين

[طارق محمود]

السلام عليكم

لو نكرمت غير الكود ليناسب ترحيل الناححين والراسبين

أين الملف الذي به الناححين والراسبين حتي أغير الكود عليه ؟؟

[أبو أنس حاجب]

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

أستاذي وسيدي وحبيبي في الله طارق محمود حفظك الله وأعزك ورفع قدرك في عليين مع الانبياء والصديقين والشهداء.

أبو أنس