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

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

هذا الكود يقوم بربط الشيتات ب Sheet1 اريد ان يقوم بعمل الكود وان لا ينفذ الامر على sheet2 و sheet7 و sheet3 وان يجعل حجم الخط في الخليه E1 في كل الشيتات 30 Sub ww() Dim h As Worksheet, sh As Worksheet, j As String Dim k As String, x As String, d As String Set h = Sheets("Sheet1") For Each sh In Sheets If Not sh.Name = "Sheet1" Then j = sh.Index + 2 k = sh.Name x = "'" & k & "'!a1" d = "'Sheet1'!a1" h.Hyperlinks.Add h.Cells(j, 1), "", x, k, k sh.Hyperlinks.Add sh.Cells(1, 5), "", d, "Sheet1", "رجوع" End If Next End Sub

لو امكن ممكن تطبقهالي على الملف المرفق ؟؟ لما بحط المعادلة بيجبلي خطأ

السلام عليكم ورحمة الله وبركاته ,,, في الملف المرفق بيانات لموظفين لدي من سنة 2022 الى سنة 2023 يوجد من الموظفين من ترك الشركة ومن مستمر معي وموظفين جدد اريد الفصل بينهم في كل شيت خاص بالحاله ومطلوب كود اخر يقوم بتحديد الموظفين الذي تم زيادة رواتبهم والذي لم يتم زيادة رواتبهم في شيت المعدل الملف المرفق موضح المطلوب شكرا لكل من ساعدني جعله الله في موازين حسناتكم OK.xlsm

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

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

السلام عليكم ورحمة الله وبركاته,,, في ها الكود يقوم بفتح عدة شيتات على حسب الاسم المكتوب في العمود C في كل خليه به المطلوب ان يقوم بنسخ البيانات وترحيلها الى الشيت المخصص لها حسب المكتوب في العمود C فمثلا في الخلية C4 مكتوب كنوز فيقوم بنسخ الصف الى شيت كنوز الخليه C5 مكتوب ادعية يقوم بنسخ الصف الى شيت ادعية ومطلوب ان يجعل العمود B في كل الشيتات size 70 ويقوم ايضا بنسخ الصف 5 ويضعه في كل الشيتات في الصف رقم 5 الملف المرفق يوضح المطلوب ..... وجزاكم الله كل خير على مساعدتكم Sub CreateSheets() Dim lra As Integer Dim My_Rg As Range Dim ListSh As Range lra = Cells(Rows.Count, "c").End(xlUp).Row Set ListSh = Worksheets("Sheet1").Range("c6:h" & lra) On Error Resume Next For Each My_Rg In ListSh If Len(Trim(My_Rg.Value)) > 0 Then If Len(Worksheets(My_Rg.Value).Name) = 0 Then Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = My_Rg.Value End If End If Worksheets("Sheet1").Select Next My_Rg Applications.Calculations = xlCalculationManual End Sub اسلاميات.xlsm

السلام عليكم ورحمة الله وبركاته مطلوب كود ييقوم بنقل اصفف حسب المكتوب في الخليه a1 في العمود E ويقوم بفتح شيت مخصص حسب الاسم المكتوب في العمود A3:A20000 الملف المرفق موضح الطلوب MD.xlsm

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

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

السلام عليكم ورحمة الله وبركاته مطلوب تعديل في هذا الكود في بداية الامر يقوم بفتح حماية جميع الشيتات بباسورد وفي نهاية الكود يقوم بقفل جميع الشيتات بباسورد محدد 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