سالي قام بنشر نوفمبر 20, 2012 قام بنشر نوفمبر 20, 2012 (معدل) اخواني الافاضل اتمني هذه المرة ان يتكرم احد من حضراتكم بالرد وطلبي هو ترحيل قيم البيانات في الجدول الموجود بشيت المبيعات بدلالة كود الصنف من الخلية Q2: AJ10 الي شيت حركة المبيعات بدأ من العمود E2 (لاول خلية فارغة ) علي ان يظهر تنبيه في حالة ادخال الفاتورة مرة اخري علما بانه يوجد معادلات داخل الجدول واملي في حالة النقل الا يكون هناك صفوف فاصلة بحركة المبيعات وهذه الحالة فقط هي التي احتاجها لاكمال برنامجي الله يبارك فيكم وعلمكم الذي اتمني الا تبخلوا علينا به ولكم شكري سلفا ترحيل.rar تم تعديل نوفمبر 20, 2012 بواسطه سالي
أبو حنــــين قام بنشر نوفمبر 20, 2012 قام بنشر نوفمبر 20, 2012 السلام عليكم هناك مربع أزرق تكتبي فيع رقم الصنف ثم تضغطي على الزر ليتم الترحيل ترحيل.rar
سالي قام بنشر نوفمبر 20, 2012 الكاتب قام بنشر نوفمبر 20, 2012 (معدل) الاستاذ ابو حنين المحترم والله ما انا عارفه ليه طلبي مو واضح انا احتاج ترحيل الجدول الموجود بشيت المبيعات من الخلية Q2: AJ10 (وهو خاص ببيانات الفاتورة)الي شيت حركة المبيعات بدلالة العمود U وهو ما يكتب به كود الصنف اي لو الجدول به رقم صنف يرحله ولو صنفين يرحلهم وهكذا المهم ان رقم الفاتورة ما يكرر وهو بالعمود R الله يبارك فيك احتاج مايكروا للموضوع ده تم تعديل نوفمبر 20, 2012 بواسطه سالي
يوسف عطا قام بنشر نوفمبر 20, 2012 قام بنشر نوفمبر 20, 2012 ساعات بيكون الطلب واضح جدا ولكن المطلوب صعب جداً مما يتطلب المزيد من الانتظار مع امكانية تنشيط الموضوع مرة كل يوم او يومين بكلمة للرفع واما بخصوص السطر الثانى من المشاركة الاولى ففيه ايحاء ببعض التقصير من جانب اعضاء المنتدى حتى ولو كان لكى طلب سابق لم يلبيه احد فلا يجب الايحاء بما يوحى به هذا السطر تقبلى احترامى
أبو حنــــين قام بنشر نوفمبر 21, 2012 قام بنشر نوفمبر 21, 2012 أعتقد انني قمت بالترحيل كما ورد في الطلب ترحيل بيانات.rar 1
سالي قام بنشر نوفمبر 21, 2012 الكاتب قام بنشر نوفمبر 21, 2012 (معدل) ساعات بيكون الطلب واضح جدا ولكن المطلوب صعب جداً مما يتطلب المزيد من الانتظار مع امكانية تنشيط الموضوع مرة كل يوم او يومين بكلمة للرفع واما بخصوص السطر الثانى من المشاركة الاولى ففيه ايحاء ببعض التقصير من جانب اعضاء المنتدى حتى ولو كان لكى طلب سابق لم يلبيه احد فلا يجب الايحاء بما يوحى به هذا السطر تقبلى احترامى الاستاذ الفاضل يوسف صاحب الحاجة اعمي لا يري الا قضاء حاجته وانا اسفة جدا لو فهم من كلامي غير ما اقصد والعفو من شيم الكرام وانتم كرماء في المنتدي بعلمكم واكيد سأنتبه مستقبلا لملاحظة حضرتك شكرا لكم تم تعديل نوفمبر 21, 2012 بواسطه سالي
سالي قام بنشر نوفمبر 21, 2012 الكاتب قام بنشر نوفمبر 21, 2012 أعتقد انني قمت بالترحيل كما ورد في الطلب الاخ الفاضل والانسان الراقي المبدع الاستاذ ابو حنين اتشرف بان اسجل لكم كل التقدير والاحترام لما ساعدتني به انار الله طريقك دائما بالخير وحفظك وحقظ الجزائر بلد المليون ونصف شهيد بحق انتم فخر لهذ المنتدي لكم ومن خلالكم لجميع مشرفي وادري واعضاء المنتدي اسمي ايات التقدير والاحترام
أبو حنــــين قام بنشر نوفمبر 21, 2012 قام بنشر نوفمبر 21, 2012 السلام عليكم العفو أختي الكريمة و جزاك الله خيرا على كلماتك الطيبة و الشكر موصول لأخي يوسف الذي ما قصد بكلامه سوى انتظار الرد من الاخوة حينما تتسنى لهم الفرصة و أعتقد أن الكود يحتوي على خطأ بيسط سأتداركه في اقرب وقت
سالي قام بنشر نوفمبر 21, 2012 الكاتب قام بنشر نوفمبر 21, 2012 (معدل) السلام عليكم العفو أختي الكريمة و جزاك الله خيرا على كلماتك الطيبة و الشكر موصول لأخي يوسف الذي ما قصد بكلامه سوى انتظار الرد من الاخوة حينما تتسنى لهم الفرصة و أعتقد أن الكود يحتوي على خطأ بيسط سأتداركه في اقرب وقت الاخ الفاضل ابو حنين حفظكم الله وحفظ لكم حنين والاسرة الكريمة شاكرة لكم وللاخ الكريم يوسف تواصلكم واهتمامكم بطلبات الاعضاء جعل الله جهودكم الخيرة في ميزان حسناتكم كما اود اعلامكم باني قد غيرت من ورقة 1 بالكود الي شيت المبيعات كذلك ورقة 2 الي شيت حركة المبيعات حتي يتسني لي نسخ الكود لاستخدامة لورقة المشتريات وحركة المشتريات ايضا واعذرني اخي الكريم لان معلوماتي قليلة جدا ومن علمكم نستفيد ونتعلم كما اثمن لكم تواضعكم الجم الذي ظهر من خلال كلماتكم " أعتقد أن الكود يحتوي على خطأ بسيط سأتداركه في اقرب وقت" لكم شكري اخي الفاضل تم تعديل نوفمبر 21, 2012 بواسطه سالي
أبو حنــــين قام بنشر نوفمبر 21, 2012 قام بنشر نوفمبر 21, 2012 السلام عليكم إن وقع خطأ في الكود السابق يرجى تغييره بالكود التالي 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]
سالي قام بنشر نوفمبر 22, 2012 الكاتب قام بنشر نوفمبر 22, 2012 (معدل) اسفة للتأخر بالرد لقد افادني الكود الاول جدا الله يبارك بكم <span style="color: rgb(0, 0, 205);"><span style="font-family: arial,helvetica,sans-serif;"><strong>استاذ ابو حنين اللهم يزيد علمكم ا% تم تعديل نوفمبر 22, 2012 بواسطه سالي
سالي قام بنشر نوفمبر 27, 2012 الكاتب قام بنشر نوفمبر 27, 2012 (معدل) الاستاذ والاخ الفاضل ابو حنين اثناء الانتهاء من البرنامج ظهرت لي مشكلة وهي ان كود نقل المبيعات يقوم بالترحيل من الفاتورة الي المبيعات بشكل متسلسل اما اثناء تطبيقة علي المشتريات لا يتم ترحيل الفاتورة الي المشتريات بشكل متسلسل ياريت من فضلك تشوف انا عندي خطأ ام ماذا مع كل تقديري لكم ولكل اساتذ تم تعديل نوفمبر 27, 2012 بواسطه سالي
أبو حنــــين قام بنشر نوفمبر 27, 2012 قام بنشر نوفمبر 27, 2012 السلام عليكم ربما الخطأ في اسم الورقة في الملف السابق كان السطر التالي هو الذي يحدد آخر خلية تحتوي على بيانات و هذا هو السطر : LR1 = ورقة2.Cells(Rows.Count, "E").End(xlUp).Row - 2 بمعنى الورقة2 هي ورقة حركة المبيعات ، غيريها حسب اسم ورقة المشتريات تأكدي من هذا
سالي قام بنشر نوفمبر 28, 2012 الكاتب قام بنشر نوفمبر 28, 2012 (معدل) السلام عليكمربما الخطأ في اسم الورقةفي الملف السابق كان السطر التالي هو الذي يحدد آخر خلية تحتوي على بياناتو هذا هو السطر : LR1 = ورقة2.Cells(Rows.Count, "E").End(xlUp).Row - 2 بمعنى الورقة2 هي ورقة حركة المبيعات ، غيريها حسب اسم ورقة المشترياتتأكدي من هذا اخي الفاضل ابو حنين حقيقي انا سعيدة جدا لردك ومساعدتي وانا احاول رفع ورقة الفاتورة وورقة المشتريات لكن النت عندي تعبان كتييييير وربنا يسهل باحاول الكود اللي حضرتك كتبته هو موجود لاني مثل ما قلت لحضرتك غيرت فقط اسم الور قة بالكود الي اسم الشيت وعلي ما ربنا يسهل وارفع الملف اوضح لحضرتك الترحيل للورقة 2 بيحجز 10 صفوف وينزل عدد الاصناف مثلا 2 في الصف 3 و 4 والفاتورة الثانية تنزل بالصف13 تم تعديل نوفمبر 28, 2012 بواسطه سالي
سالي قام بنشر نوفمبر 28, 2012 الكاتب قام بنشر نوفمبر 28, 2012 الاستاذ واخي الفاضل ابو حنين اامل الاطلاع علي الملف المرفق ومراجعة الكود لمعالجة الحالة مع كل التقدير لكم Book1.rar
الـعيدروس قام بنشر ديسمبر 1, 2012 قام بنشر ديسمبر 1, 2012 (معدل) السلام عليكم جرب هذا التعديل 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 تم تعديل ديسمبر 1, 2012 بواسطه عباد
سالي قام بنشر ديسمبر 1, 2012 الكاتب قام بنشر ديسمبر 1, 2012 (معدل) الاخ الاستاذ ابو نصار الحمد لله تم المطلوب بعد تعديل الكود شاكرة لكم والله يبارك فيكم وفي علمكم والشكر موصول لجميع الاساتذة الافاضل الذين هم عونا لنا تم تعديل ديسمبر 1, 2012 بواسطه سالي
سالي قام بنشر ديسمبر 3, 2012 الكاتب قام بنشر ديسمبر 3, 2012 (معدل) الاساتذة الكرام كود الاستاذ ابو حنين استطعت ان اضيف كود الغاء حماية الورقة قبل نقل البيانات لها ومن ثم اعادة الحماية لها لكن كود الاستاذ ابو نصار حاولت كثيرا لكن لم اوفق الرجاء اعلامي اين اكتبه في كود الاستاذ ابو نصار الكود هو [/center] [center] Sheets("المشتريات").Select ActiveSheet.Unprotect وبعد اتمام الكود يكون الامر ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True[/center] [center] تم تعديل ديسمبر 3, 2012 بواسطه سالي
أبو حنــــين قام بنشر ديسمبر 3, 2012 قام بنشر ديسمبر 3, 2012 بعد اذن اخي ابو نصار بالنسبة لإلغاء للحماية نصع السطر كالتالي : 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 و البقية لا يتغير
سالي قام بنشر ديسمبر 3, 2012 الكاتب قام بنشر ديسمبر 3, 2012 اللله يبارك فيكم استاذ ابو حنين والاستاذ ابو نصار تم المطلوب والحمد لله شاكرة لكما سرعة الاجابة
سالي قام بنشر ديسمبر 5, 2012 الكاتب قام بنشر ديسمبر 5, 2012 الاساتذة الكرام ابو حنين وابو نصار حفظكما الله حقيقي انا اسفة جدا لكثرة طلباتي لكن طمعي في سعة صدركم وعلمكم وتخصص المنتدي يجعلني طماعة شوية كود الطباعة يقوم بعمل نسخة ويحفظها بنفس الفولدر وبما انه يتم الاحتفاظ بنسخ من فواتير المبيعات ومدفوعات الموردين ومقبوضات العملاء في فولدر الفواتير الذي سيكون فيه فولدر للمبيعات وايضا الموردين كذلك العملاء فاتمني تعديل الكود بحيث يكون الحفظ في 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
الـعيدروس قام بنشر ديسمبر 5, 2012 قام بنشر ديسمبر 5, 2012 السلام عليكم تفضل اخي 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
الردود الموصى بها