محمد عبد الناصر

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

السلام عليكم ورحمة الله وبركاته مطلوب تعديل في هذا الكود في بداية الامر يقوم بفتح حماية جميع الشيتات بباسورد وفي نهاية الكود يقوم بقفل جميع الشيتات بباسورد محدد Sub go_mod5alat() If Sheets("ÇáãÏÎáÇÊ").Range("c6") = "" Then MsgBox "ÏÎá ÇÓÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜã ÇáÚãããããíííííííííííííííííííááááááá", vbExclamation: Exit Sub Sheets("ÝÇÊæÑÉ ãÏÎáÇÊ").PrintOut Dim ws As Worksheet, Data As Worksheet, ShName As String Dim LR As Long, ER As Long, x As Integer Set Data = Sheets("ÇáãÏÎáÇÊ") ShName = Data.Range("C6").Text ER = Data.Range("B" & Rows.Count).End(3).Row x = ER - 7 For Each ws In Worksheets If ws.Name = ShName Then LR = ws.Range("B" & Rows.Count).End(3).Row ws.Name = ShName ws.Range("B" & LR + 1).Resize(x, 17) = Data.Range("B10").Resize(x, 17).Value End If Next Sheets("ÇáãÏÎáÇÊ").Protect Password:="20125907275" Sheets("sheet1").Unprotect Password:="20125907275" Dim strName As String, sh As Worksheet strName = Trim(Sheet4.Range("am14").Value) For Each sh In Worksheets If sh.Name = strName Then Exit Sub Next sh Sheet4.Copy after:=Sheets(Sheets.Count) Sheets("sheet1 (2)").Name = strName With Sheets(strName) .Shapes("Button 1").Delete With .Range("b10:am10000") .Value = .Value End With Sheets("ÇáãÏÎáÇÊ").Range("B10:B1000").ClearContents Sheets("ÇáãÏÎáÇÊ").Range("d10:d1000").ClearContents Sheets("ÇáãÏÎáÇÊ").Range("h10:h1000").ClearContents Sheets("ÇáãÏÎáÇÊ").Range("n10:n1000").ClearContents Sheets("ÇáãÏÎáÇÊ").Range("c6").ClearContents Sheets("ÇáãÏÎáÇÊ").Protect Password:="20125907275" Sheets("ÇáãÏÎáÇÊ").Select Range("A1").Select ActiveWorkbook.Save End Sub

ماشاء الله اخي الكريم هو المطلوب تمام شكرا لك وبارك الله لك

السلام عليكم ورحمة الله وبركاته هل من طريقة او كود يقوم باخفاء مسميات الاعمدة مثل A B C D والصفوف مثل 1 2 3 4

ماشاء الله استاذ محي الدين بارك الله فيك وفي علمك وجزاك كل خير

السلام عليكم ورحمة الله وبركاته هذا الكود يقوم بتفح ورقة جديدة على حسب المكتوب في AM14 المطلوب ان يقوم بقفل و حماية هذه الورقة الذي يقوم بفتحها لعدم العبث او تخريب البيانات بها Sub CopySheet() Dim strName As String, Sh As Worksheet strName = Trim(Sheet4.Range("am14").Value) For Each Sh In Worksheets If Sh.Name = strName Then Exit Sub Next Sh Sheet4.Copy after:=Sheets(Sheets.Count) Sheets("sheet1 (2)").Name = strName With Sheets(strName) .Shapes("Button 1").Delete With .Range("b10:am1009") .Value = .Value End With End With Sheets("الشاشة الرئيسية").Select Range("A1").Select End Sub

اريد اضافة البحث اولا في شيت المدخلات فهكذا يكون ؟ If Sheets("المدخلات").Range("c6") = "" Or IsEmpty(ShName) Then MsgBox "دخل اسم العمممممييييييللللللل", vbExclamation: Exit Sub

شكرا اخي الكريم تم العمل بنجاح

يعطي خطأ فالكود حتى عند كتابة اسم بداخل الخلية

السلام عليكم ورحمة الله وبركاته مطلوب اضافة على هذا الكود اذا كانت الخلية C6 فارغة فلا يقوم بعمل الكود ولا يفعل اي شيء ويعطي رسالة تحذير بان الخلية فارغة واذا كانت ممتلئة فيقوم عمل الكود بشكل طبيعي Sub go_mod5alat() Sheets("المدخلات").Unprotect Password:="2020" Dim ws As Worksheet, Data As Worksheet, ShName As String Dim LR As Long, ER As Long, x As Integer Set Data = Sheets("المدخلات") ShName = Data.Range("C6").Text ER = Data.Range("B" & Rows.Count).End(3).Row x = ER - 7 For Each ws In Worksheets If ws.Name = ShName Then LR = ws.Range("B" & Rows.Count).End(3).Row ws.Name = ShName ws.Range("B" & LR + 1).Resize(x, 17) = Data.Range("B10").Resize(x, 17).Value Sheets("المدخلات").Protect Password:="2020" ActiveWorkbook.Save End If Next End Sub

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

السلام عليكم ورحمة الله وبركاته ,,,,, مطلوب كود يقوم باستدعاء بيانات على حسب التاريخ المكتوب في شيت "فاتورة تاريخ" في الخلية c2 و c3 وعلى حسب اسم العميل المكتوب في الخلية C1 وان لا يقوم بالبحث في هذه الشيتات ( بيانات المخزن - المدخلات - المرتجع - sheet1 ) فقط يقوم باستدعاء البيانات من اسم الشيت المكتوب في الخليه C1 على حسب الفترة المكتوبة في C2 و C3 في شيت "فاتورة تاريخ" الملف المرفق موضح المطلوب استدعاء بيانات بالتاريخ.xlsm

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

السلام عليكم ورحمة الله وبركاته في هذا الكود يقوم بنسخ Sheet1 وفتح ورقة جديدة على حسب المكتوب في Sheet1 في الخلية O14 والكود يقوم بنقل البيانات التي في الورقة بدون اي دوال المطلوب ان ينقل البيانات بدون دوال من العمود A10 الى Z400 وبقيت الخلايا يترك الدوال بداخلها الملف المرفق موضح المطلوب Sub CopySheet() Dim strName As String, SH As Worksheet strName = Trim(Sheet4.Range("o14").Value) For Each SH In Worksheets If SH.Name = strName Then Exit Sub Next SH Sheet4.Copy after:=Sheets(Sheets.Count) Sheets("sheet1 (2)").Name = strName With Sheets(strName) .Shapes("Button 1").Delete .Cells.Copy .Cells.PasteSpecial xlPasteValues End With Application.CutCopyMode = False Sheets("sheet1").Select Range("A1").Select End Sub نسخ الشيت.xlsm

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

السلام عليكمورحمة الله وبركاته ,,, مطلوب التعديل على هذا الكود فهو يقوم بتجميع الارقام من العمود D8 ويضع الناتج في شيت "بيان الاربح" في العمود C5 ويقوم بتجميع الارقام من العمود F8 ويضع الناتج في "شيت الارباح" في العمود D5 ثم يقوم بعمليه حسابية الضرب ويظهر الناتج في العمود G8 على حسب اسم الصنف المكتوب في العمود B8 في شيت بيان الارباح المطلوب ان يقوم يتجميع الارقام من جميع الشيتات من العمود D10 ويضعها في شيت "بيان المخزن" في العمود D10 ويجمع الارقام من جميع الشيتات من العمود E10 ويضعها في العمود E10 في شيت " بيان المخزن" الكود يقوم بتجميع الارقام من كل الشيتات في الملف ما عدا شيتات محدده كما هو مذكور في الكود وان امكن ان يتم تطبيقه في الملف المرفق Option Explicit Sub test() Dim a, x, w Dim i& Dim sht As Worksheet x = Array("بيانات المخزن", "المدخلات", "مديونيات العميل", "المرتجع") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With CreateObject("scripting.dictionary") For Each sht In ActiveWorkbook.Worksheets If IsError(Application.Match(sht.Name, x, 0)) Then a = sht.Cells(8, 1).Resize(sht.Cells(Rows.Count, 1).End(xlUp).Row - 7, 7) For i = 1 To UBound(a) If Not .exists(a(i, 2)) Then .Add a(i, 2), Array(a(i, 4), a(i, 3) * a(i, 4), a(i, 7)) Else w = .Item(a(i, 2)) w(0) = w(0) + a(i, 4): w(1) = w(1) + a(i, 3) * a(i, 4): w(2) = w(2) + a(i, 7) .Item(a(i, 2)) = w End If Next End If Next For i = 5 To Range(Cells(5, 2), Cells(5, 2).End(xlDown)).Count If Cells(i, 2) = "" Then Exit Sub If Not .exists(Cells(i, 2)) Then Cells(i, 4).Resize(, 3) = .Item(Cells(i, 2).Value) Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub برنامج الترحيل.xlsm

ماشاء الله بارك الله فيكم وفي علمكم وجه الله الله في ميزان حسناتكم

اذا امكن ان تكتبها داخل الكود بالاعلى جزاك الله كل خير

اعتذر منك اخي الكريم اذا بامكانك تعديل الكود لكي يجمع عدد القطع المباعه و عدد المرتجع في هذا الملف في شيت بيانات المخزن اثابك الله من فضله برنامج الترحيل.xlsm

السلام عليكم ورحمة الله وبركاته في هذا الكود يقوم بترحيل البيانات الى شيت محدد على حسب اسم الشيت المكتوب في الخليه C2 اريد تعديل هذا الكود بحيث اذا لم يجد بيانات في العمود B10:B20 لا يقوم بترحيل اي صفوف فارغة ولا يفعل اي شيء لان عند الضغط عليه يقوم بترحيل صفوف فارغه Sub SSheet() Dim ws As Worksheet, Data As Worksheet, ShName As String Dim LR As Long, ER As Long, x As Integer Set Data = Sheets("المدخلات") ShName = Data.Range("C2").Text ER = Data.Range("B" & Rows.Count).End(3).Row x = ER - 7 For Each ws In Worksheets If ws.Name = ShName Then LR = ws.Range("B" & Rows.Count).End(3).Row ws.Name = ShName ws.Range("B" & LR + 1).Resize(x, 11) = Data.Range("B10").Resize(x, 11).Value End If Next End Sub

ماشاء الله وبارك الله عز وجل في علمك اسال الله ان يرزقك الخير وان يجعله في موازين حسناتك

اعتذر منك اريد فقط تجميع كل صنف تم بيعه من شيتات العملاء فقط

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

السلام عليكم ورحمة الله وبركاته,,,, في الملف المرفق ملف يوجد به عدة شيتات باسماء مختلفة اريد في شيت "بيان الارباح" في عمود "سعر البيع" ان يقوم بجمع اسم الصنف المحدد في العمود B بدون ان يجمع اسم الصنف من شيت( المخزن و المدخلات و الفاتورة و sheet1 ) بحيث اذا قمت بفتح شيت لعميل جديد يقوم بجمع الاصناف المباعه لهذا العميل والعملاء القديمة يجمع فقط كل الصنف المحدد من العملاء فقط الملف المرفق موضح المطلوب اعتذر لضغط الملف لكبر مساحته Mohamed Nasser.rar

المشكلة في تسلسل الارقام في اول عمود المسمى م