مساعدة من عمالقة المنتدى

[seao]

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

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

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

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

Book1.rar

[طارق محمود]

السلام عليكم

اخى الكريم

غيرت لك المعادلة التي بالعمود G لتكون أكثر شمولا

وتكون معتمدة علي البيانات في ورقة home فقط ولتجنب إعتمادها علي الورقات التالية

وبفرض أن التاريخ طبعا مسجل بالترتيب من الأصغر للأكبر

تم عمل كود الترحيل لورقة العميل

وإنشاء ورقة جديدة إن لم يكن للعميل ورقة من قبل

وذلك عن طريق عمل ورقة ثابتة بالملف إسمها Sample مخفية

وفي حالة إن لم يكن للعميل ورقة من قبل ، نظهر تلك الورقة ونأخذ منها نسخة في آخر الملف ونضع في النسخة إسم العميل في الخلية B2

ثم نعيد إخفاء الورقة Sample

فضلت الإحتفاظ بالبيانات بعد ترحيلها (عدم مسحها من ورقة home بعد ترحيلها)

مع إضافة تنبيه أن هذا البيان سبق ترحيله (إن وجد هذا)

هذا هو الكود

Sub Shift()

Dim CL_Name(999), Inv_Num(999), In_Date(999), In_Amnt(999) As Variant


Worksheets("home").Select

Reg_No = [C10000].End(xlUp).Row - 3

[C10000].End(xlUp).Select


'==============	READ DATA   =============

For i = 1 To Reg_No

	CL_Name(i) = Range("C" & i + 3).Value

	Inv_Num(i) = Range("D" & i + 3).Value

	In_Date(i) = Range("E" & i + 3).Value

	In_Amnt(i) = Range("F" & i + 3).Value

Next i


'______________________________________________

For qq = 1 To Reg_No


	x = Worksheets.Count


' =============   Write Data   ===============

	For i = 1 To x

	If Worksheets(i).Name = CL_Name(qq) Then GoTo 100

	Next i

   add_n_sht (CL_Name(qq)) 	'In case no sheets in this name

100


	Worksheets(CL_Name(qq)).Select

	Last_R = [A10000].End(xlUp).Row + 2


 	For j = 6 To Last_R


    	If Range("A" & j).Value = Inv_Num(qq) And Range("B" & j).Value = In_Date(qq) Then ' Check Previous Data

        	MsgBox ("هذا اليان برقم الفاتورة " & Inv_Num(qq) & Chr(10) & "والتاريخ" & _

        	In_Date(qq) & Chr(10) & "، سبق تسجيله من قبل " & Chr(10) & " لايمكن إعادة التسجيل")

        	GoTo 150

    	End If


	Next j

        	[A10000].End(xlUp).Select


        	ActiveCell.Offset(1, 0).Value = Inv_Num(qq)

        	ActiveCell.Offset(1, 1).Value = In_Date(qq)


        	If Inv_Num(qq) = "توريد نقدية" Then

            	ActiveCell.Offset(1, 3).Value = In_Amnt(qq)

        	Else

            	ActiveCell.Offset(1, 2).Value = In_Amnt(qq)

        	End If


150

Next qq


Sheets("home").Select


End Sub


Function add_n_sht(n_acc)

 x = Worksheets.Count

    	Sheets("Sample").Visible = True

	Sheets("sample").Select 'in case no sheets in this name


	Sheets("sample").Copy after:=Sheets(x)

	ActiveSheet.Name = n_acc

	[B2].Value = n_acc

	Sheets("Sample").Visible = False

End Function

بقي موضوع الرابط التشعبى لم أجد الوقت لضبطه

تفضل المرفق أيضا وبه الكود

يبدو ان الرفع به مشكلة بالمنتدي

تجد المرفق علي الرابط

http://www.4shared.com/file/rhOE3jNs/___online.html

[طارق محمود]

السلام عليكم

الآن يمكنني رفع الملفات

تفضل الملف

ترحيل وورقة جديدة.rar

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

استاذنا طارق

كل الشكر ..... دوما نستفيد جدا

وفقك الله

ابو الحارث