اذهب الي المحتوي
أوفيسنا

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


سالي

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

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

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

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

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

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

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

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

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

ترحيل.rar

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

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

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

انا احتاج ترحيل الجدول الموجود بشيت المبيعات من الخلية Q2: AJ10

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

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

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

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

شكرا لكم

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

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

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

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

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

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

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

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

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

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

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

السلام عليكم

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

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

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

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

السلام عليكم

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

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

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

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

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

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

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

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

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

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

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

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

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

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

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

السلام عليكم

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



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>استاذ ابو حنين اللهم يزيد علمكم ا%

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

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

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

وهي

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

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

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

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

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

السلام عليكم

ربما الخطأ في اسم الورقة

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

و هذا هو السطر :


	 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

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

السلام عليكم

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


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

تم تعديل بواسطه عباد
رابط هذا التعليق
شارك

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

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

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

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

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

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

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

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

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

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

الكود هو

 [/center]


[center]  Sheets("المشتريات").Select

    ActiveSheet.Unprotect

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

    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True[/center]


[center]

تم تعديل بواسطه سالي
رابط هذا التعليق
شارك

بعد اذن اخي ابو نصار

بالنسبة لإلغاء للحماية نصع السطر كالتالي :


Sub hh()

Sheets("المشتريات").Unprotect

Dim m As Range

الى السطر التالي ليتم حماية الملف

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, "ترحيل"

Sheets("المشتريات").Protect

'--------------------------------------------------------------------------------------

For i = Sheets("المشتريات").Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1

و البقية لا يتغير

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

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

حقيقي انا اسفة جدا لكثرة طلباتي

لكن طمعي في سعة صدركم وعلمكم وتخصص المنتدي يجعلني طماعة شوية

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

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

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

فاتمني تعديل الكود بحيث يكون الحفظ في D/فواتير/المبيعات

وسأطبقة علي الباقي الله يبارك بكم

وهناك استفسار اخر

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

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

شاكرة لكم مرة ثانية سعة الصدر


If ActiveSheet.CheckBox1.Value = True Then

Activewindow.SelectedSheets.PrintOut

Else

GoTo 1

End If

حفظ الفاتورة في ملف منفصل

1:

If Range("i5") = "" Then

MsgBox ("ادخل رقم الفاتورة")

Exit Sub

Else

Dim full_path As String

Dim aah As String

m = ActiveWorkbook.Name

full_path = ThisWorkbook.Path & "\" & [i5].Value & " مبيعات"

Debug.Print full_path

Workbooks.Add

N = ActiveWorkbook.Name

Windows(m).Activate

ActiveSheet.Range("b1:j11").Copy

Windows(N).Activate

ActiveSheet.Range("b1:j16").Select

ActiveSheet.Paste

Range("b1:j16").Select

Selection.Copy

Range("b1:j16").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False




Columns("b:J").EntireColumn.AutoFit

Range("b1").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [i5] & ".xls" Then

MsgBox "الملف موجود بالفعل..."

ActiveWorkbook.Close

Application.DisplayAlerts = True

Exit Sub

Else

ActiveWorkbook.SaveAs Filename:=full_path

Application.DisplayAlerts = True

ActiveWorkbook.Close

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

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

السلام عليكم

تفضل اخي


Sub Path_F()

Dim My_Pass$

'**********************************

My_Pass = "123"

Sheets("إسم الورقة").Unprotect Password:=My_Pass

'

'**********************************

If ActiveSheet.CheckBox1.Value = True Then

Activewindow.SelectedSheets.PrintOut

Else

GoTo 1

End If

''حفظ الفاتورة في ملف منفصل

'1:

If Range("i5") = "" Then

MsgBox ("ادخل رقم الفاتورة")

Exit Sub

Else

Dim full_path As String

Dim aah As String

m = ActiveWorkbook.Name

'*************************************

'

full_path = "D:\فواتير\المبيعات" 'ThisWorkbook.Path & "\" & [i5].Value & " مبيعات"

'

'*************************************

Debug.Print full_path

Workbooks.Add

N = ActiveWorkbook.Name

Windows(m).Activate

ActiveSheet.Range("b1:j11").Copy

Windows(N).Activate

ActiveSheet.Range("b1:j16").Select

ActiveSheet.Paste

Range("b1:j16").Select

Selection.Copy

Range("b1:j16").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Columns("b:J").EntireColumn.AutoFit

Range("b1").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [i5] & ".xls" Then

MsgBox "الملف موجود بالفعل..."

ActiveWorkbook.Close

Application.DisplayAlerts = True

Exit Sub

Else

ActiveWorkbook.SaveAs Filename:=full_path

Application.DisplayAlerts = True

ActiveWorkbook.Close

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

Sheets("إسم الورقة").Protect Password:=My_Pass

End Sub

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

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

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

Important Information