37 رد (ردود) على هذا الموضوع

[سالي]

اخواني الافاضل

اتمني هذه المرة ان يتكرم احد من حضراتكم بالرد

وطلبي هو ترحيل قيم البيانات في الجدول الموجود بشيت المبيعات بدلالة كود الصنف من الخلية Q2: AJ10

الي شيت حركة المبيعات بدأ من العمود E2 (لاول خلية فارغة ) علي ان يظهر تنبيه في حالة ادخال الفاتورة مرة اخري

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

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

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

ولكم شكري سلفا

ملفات مرفقة

•  ترحيل.rar   16.35كيلو   40 عدد مرات التحميل

تم تعديل هذه المشاركة بواسطة سالي: 20 نوفمبر 2012 - 09:04 م

[أبو حنين]

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

ملفات مرفقة

•  ترحيل.rar   17.15كيلو   61 عدد مرات التحميل

[سالي]

الاستاذ ابو حنين المحترم

والله ما انا عارفه ليه طلبي مو واضح

انا احتاج ترحيل الجدول الموجود بشيت المبيعات من الخلية Q2: AJ10
(وهو خاص ببيانات الفاتورة)الي شيت حركة المبيعات بدلالة العمود U وهو ما يكتب به كود الصنف

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

الله يبارك فيك احتاج مايكروا للموضوع ده

تم تعديل هذه المشاركة بواسطة سالي: 21 نوفمبر 2012 - 12:26 ص

[يوسف عطا]

ساعات بيكون الطلب واضح جدا

ولكن المطلوب صعب جداً

مما يتطلب المزيد من الانتظار

مع امكانية تنشيط الموضوع مرة كل يوم او يومين بكلمة للرفع

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

تقبلى احترامى

[أبو حنين]

أعتقد انني قمت بالترحيل كما ورد في الطلب

ملفات مرفقة

•  ترحيل بيانات.rar   17.58كيلو   66 عدد مرات التحميل

[سالي]

ساعات بيكون الطلب واضح جدا

ولكن المطلوب صعب جداً

مما يتطلب المزيد من الانتظار

مع امكانية تنشيط الموضوع مرة كل يوم او يومين بكلمة للرفع

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

تقبلى احترامى

الاستاذ الفاضل يوسف

صاحب الحاجة اعمي لا يري الا قضاء حاجته

وانا اسفة جدا لو فهم من كلامي غير ما اقصد

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

واكيد سأنتبه مستقبلا لملاحظة حضرتك

شكرا لكم

تم تعديل هذه المشاركة بواسطة سالي: 21 نوفمبر 2012 - 10:25 ص

[سالي]

أعتقد انني قمت بالترحيل كما ورد في الطلب

الاخ الفاضل والانسان الراقي المبدع الاستاذ ابو حنين

اتشرف بان اسجل لكم كل التقدير والاحترام

لما ساعدتني به

انار الله طريقك دائما بالخير

وحفظك وحقظ الجزائر بلد المليون ونصف شهيد

بحق انتم فخر لهذ المنتدي

لكم ومن خلالكم لجميع مشرفي وادري واعضاء المنتدي

اسمي ايات التقدير والاحترام

[أبو حنين]

السلام عليكم

العفو أختي الكريمة و جزاك الله خيرا على كلماتك الطيبة

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

و أعتقد أن الكود يحتوي على خطأ بيسط سأتداركه في اقرب وقت

[سالي]

السلام عليكم

العفو أختي الكريمة و جزاك الله خيرا على كلماتك الطيبة

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

و أعتقد أن الكود يحتوي على خطأ بيسط سأتداركه في اقرب وقت

الاخ الفاضل ابو حنين

حفظكم الله وحفظ لكم حنين والاسرة الكريمة

شاكرة لكم وللاخ الكريم يوسف تواصلكم واهتمامكم بطلبات الاعضاء

جعل الله جهودكم الخيرة في ميزان حسناتكم

كما اود اعلامكم باني قد غيرت من ورقة 1 بالكود الي شيت المبيعات

كذلك ورقة 2 الي شيت حركة المبيعات

حتي يتسني لي نسخ الكود لاستخدامة لورقة المشتريات وحركة المشتريات ايضا

واعذرني اخي الكريم لان معلوماتي قليلة جدا

ومن علمكم نستفيد ونتعلم

كما اثمن لكم تواضعكم الجم الذي ظهر من خلال كلماتكم " أعتقد أن الكود يحتوي على خطأ بسيط سأتداركه في اقرب وقت"

لكم شكري اخي الفاضل

تم تعديل هذه المشاركة بواسطة سالي: 21 نوفمبر 2012 - 12:58 م

[أبو حنين]

السلام عليكم
إن وقع خطأ في الكود السابق يرجى تغييره بالكود التالي

Sub HH()
Dim m As Range
For Each m In ورقة2.Range("F3:F1000")
	    If m.Text Like ورقة1.Range("R3").Text Then
MsgBox "رقم هذه الفاتورة موجود مسبقا", vbCritical, "خطأ"
Exit Sub
End If
Next
'----------------------------------------------------------------------------
Application.ScreenUpdating = False
    LR = ورقة1.Cells(Rows.Count, "Q").End(xlUp).Row + 1
    x = 3
	    LR1 = ورقة2.Cells(Rows.Count, "E").End(xlUp).Row - 2
		    For i1 = 2 To LR
			    If ورقة1.Cells(i1, 17).Text <> "" Then
					 ورقة1.Range("q" & i1).Resize(1, 20).Copy
						 ورقة2.Range("E" & LR1 + x).PasteSpecial xlPasteValues
					 x = x + 1
				    End If
			    Next
		    Application.ScreenUpdating = True: Application.CutCopyMode = False
MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "ترحيل"
'--------------------------------------------------------------------------------------
For i = ورقة2.Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
    If WorksheetFunction.CountIf(ورقة2.Range("F1:F" & i), ورقة2.Range("F" & i).Value) > 1 Then
		 ورقة2.Range("F" & i) = ""
	   End If
	 Next i
ورقة2.Select
End Sub[/font]
[font=arial,helvetica,sans-serif]

[سالي]

اسفة للتأخر بالرد

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

<span style="color: rgb(0, 0, 205);"><span style="font-family: arial,helvetica,sans-serif;"><strong>استاذ ابو حنين اللهم يزيد علمكم ا%

تم تعديل هذه المشاركة بواسطة سالي: 23 نوفمبر 2012 - 12:09 ص

[سالي]

الاستاذ والاخ الفاضل ابو حنين

اثناء الانتهاء من البرنامج ظهرت لي مشكلة

وهي

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

اما اثناء تطبيقة علي المشتريات لا يتم ترحيل الفاتورة الي المشتريات بشكل متسلسل

ياريت من فضلك تشوف انا عندي خطأ ام ماذا

مع كل تقديري لكم ولكل اساتذ

تم تعديل هذه المشاركة بواسطة سالي: 28 نوفمبر 2012 - 01:07 ص

[أبو حنين]

السلام عليكم
ربما الخطأ في اسم الورقة
في الملف السابق كان السطر التالي هو الذي يحدد آخر خلية تحتوي على بيانات
و هذا هو السطر :

	 LR1 = ورقة2.Cells(Rows.Count, "E").End(xlUp).Row - 2

بمعنى الورقة2 هي ورقة حركة المبيعات ، غيريها حسب اسم ورقة المشتريات
تأكدي من هذا

[سالي]

السلام عليكمربما الخطأ في اسم الورقةفي الملف السابق كان السطر التالي هو الذي يحدد آخر خلية تحتوي على بياناتو هذا هو السطر :

LR1 = ورقة2.Cells(Rows.Count, "E").End(xlUp).Row - 2

بمعنى الورقة2 هي ورقة حركة المبيعات ، غيريها حسب اسم ورقة المشترياتتأكدي من هذا

اخي الفاضل ابو حنين

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

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

وربنا يسهل باحاول

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

وعلي ما ربنا يسهل وارفع الملف اوضح لحضرتك

الترحيل للورقة 2 بيحجز 10 صفوف وينزل عدد الاصناف مثلا 2 في الصف 3 و 4

والفاتورة الثانية تنزل بالصف13

تم تعديل هذه المشاركة بواسطة سالي: 28 نوفمبر 2012 - 04:42 ص

[سالي]

الاستاذ واخي الفاضل ابو حنين

اامل الاطلاع علي الملف المرفق

ومراجعة الكود لمعالجة الحالة

مع كل التقدير لكم

ملفات مرفقة

•  Book1.rar   75.31كيلو   52 عدد مرات التحميل

[سالي]

للرفع

[سالي]

للرفع

[عباد]

السلام عليكم

جرب هذا التعديل

Sub hh()
Dim m As Range
For Each m In Sheets("المشتريات").Range("F3:F1000")
If m.Text Like Sheets("فاتورة مشتريات").Range("j3").Text Then
MsgBox "رقم هذه الفاتورة موجود مسبقا", vbCritical, "خطأ"
Exit Sub
End If
Next
'----------------------------------------------------------------------------
Application.ScreenUpdating = False
LR = Sheets("فاتورة مشتريات").Cells(Rows.Count, "Q").End(xlUp).Row
LR1 = Sheets("المشتريات").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Row
With Sheet6
.Range(Cells(2, 17), Cells(A_S, 35)).Copy
  Sheets("المشتريات").Cells(LR1, 5).PasteSpecial xlPasteValues
End With
Application.ScreenUpdating = True: Application.CutCopyMode = False
MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "ترحيل"
'--------------------------------------------------------------------------------------
For i = Sheets("المشتريات").Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Sheets("المشتريات").Range("F1:F" & i), Sheets("المشتريات").Range("F" & i).Value) > 1 Then
Sheets("المشتريات").Range("F" & i) = ""
End If
Next i
Sheets("فاتورة مشتريات").Select
End Sub
Public Function A_S() As Long
Dim X, LR, R
LR = Sheets("فاتورة مشتريات").Cells(Rows.Count, "Q").End(xlUp).Row
With Sheet6
With .Range(.Cells(2, 17).Address, .Cells(LR, 17).Address)
For R = 1 To .Rows.Count
If IsDate(.Cells(R, 1)) Then
  X = .Cells(R, 1).Row
End If
Next
End With
End With
A_S = X
End Function

تم تعديل هذه المشاركة بواسطة عباد: 01 ديسمبر 2012 - 03:44 ص

[سالي]

الاخ الاستاذ ابو نصار

الحمد لله تم المطلوب بعد تعديل الكود

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

والشكر موصول لجميع الاساتذة الافاضل

الذين هم عونا لنا

تم تعديل هذه المشاركة بواسطة سالي: 01 ديسمبر 2012 - 03:01 م

[سالي]

الاساتذة الكرام

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

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

الرجاء اعلامي اين اكتبه في كود الاستاذ ابو نصار

الكود هو

[/center]
[center]  Sheets("المشتريات").Select
    ActiveSheet.Unprotect
	وبعد اتمام الكود يكون الامر
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True[/center]
[center]

تم تعديل هذه المشاركة بواسطة سالي: 03 ديسمبر 2012 - 08:19 م