أيهاب ممدوح

السلام عليكم ارجوا من الاخوة الاعزاء يوجد ملف به اكثر من شيت اريد ترحيل جميع البيانات للمستأجر المتأخر الي شيت اخر اسمه التأخير برنامج ايجار.xlsm

الاستاذ سليم الكود المرفق يعمل جيدا في كل الامور ولكن اريد من حضرتك عند الضغط علي كلمه الرئيسيه (في اي صفحه في خليه D4) ان يخفي الصفحه التي ضغط علي كلمه الرئيسيه وينتقل الي الصفحه التي بها القائمه باسماء الصفحات TEST_HYPER2.xlsm

شكرا استاذنا الكريم جزاك الله خير

السلام عليكم كود رائع وجميل لكن هل بالامكان جعله يعمل عند فتح الصفحه وليس الملف ehab2 (1).xlsm

السلام عليكم يوجد كود عمل قائمه باسماء الصفحات و هايبر لينك باسم كل صفحة ولكن عند حذف الصفحة او تعديل اسمها او مكانها لم يعيد تحديث القائمة المطلوب جعل الكود يحدث القائمة باستمرار مع فتح الملف ehab.xlsm

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

السلام عليكم يوجد كود عمل قائمه باسماء الصفحات وعمل هايبر لينك باسم الصفحه وهيبر لينك داخل الصفحات بالعوده الي الصفحه الرئيسيه لكن الهيبر لينك لا يعمل في حاله اخفاء الصفحات المطلوب عند الضغط علي اسم الصفحه المخفيه يعمل الكود وعند الضغط علي كلمه الرئيسيه يخفي الصفحه والعوده الي الصفحه الرئيسيه شكراNew Microsoft Excel Worksheet.xlsx

لو سمحتم هل من الممكن استبدال الكود المرفق بكود مختصر وقابل للتعديل والاضافه Sub ÊÃÎíÑ() Application.ScreenUpdating = False Sheets("ÊÃÎíÑ").Select Range("B3:R5000").SpecialCells(xlCellTypeConstants).ClearContents Range("H5").Select Sheets("ÓáØÇä").Select ActiveSheet.Range("$A$1:$A$48").AutoFilter Field:=1, Criteria1:="=A", _ Operator:=xlOr, Criteria2:="=" Range("B3:q102").Select Selection.Copy Sheets("ÊÃÎíÑ").Select Range("B3").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H3").Select Sheets("ÓáØÇä").Select Application.CutCopyMode = False Range("H3").Select ActiveSheet.Range("$A$1:$A$48").AutoFilter Field:=1 Sheets("ÇáÌæåÑÉ").Select ActiveSheet.Range("$A$1:$A$40").AutoFilter Field:=1, Criteria1:="=A", _ Operator:=xlOr, Criteria2:="=" Range("B3:Q115").Select Selection.Copy Sheets("ÊÃÎíÑ").Select Range("B55").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H55").Select Sheets("ÇáÌæåÑÉ").Select Application.CutCopyMode = False Range("H3:K3").Select ActiveSheet.Range("$A$1:$A$40").AutoFilter Field:=1 Sheets("ÇáÈÇíæäíå").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1, Criteria1:="=A", _ Operator:=xlOr, Criteria2:="=" Range("B3:Q101").Select Selection.Copy Sheets("ÊÃÎíÑ").Select Range("B105").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H105").Select Sheets("ÇáÈÇíæäíå").Select Application.CutCopyMode = False Range("H3:K3").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1 Sheets("ÇáÑÇßå").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1, Criteria1:="=A", _ Operator:=xlOr, Criteria2:="=" Range("B3:Q60").Select Selection.Copy Sheets("ÊÃÎíÑ").Select Range("B155").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H155").Select Sheets("ÇáÑÇßå").Select Application.CutCopyMode = False Range("H3:K3").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1 Sheets("ÓÚÏ").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1, Criteria1:="=A", _ Operator:=xlOr, Criteria2:="=" Range("B3:Q88").Select Selection.Copy Sheets("ÊÃÎíÑ").Select Range("B206").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H206").Select Sheets("ÓÚÏ").Select Application.CutCopyMode = False Range("H3:K3").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1 Sheets("äÇíÝ").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1, Criteria1:="=A", _ Operator:=xlOr, Criteria2:="=" Range("B3:Q53").Select Selection.Copy Sheets("ÊÃÎíÑ").Select Range("B255").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H255").Select Sheets("äÇíÝ").Select Application.CutCopyMode = False Range("H3:K3").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1 Sheets("äÇÕÑ").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1, Criteria1:="=A", _ Operator:=xlOr, Criteria2:="=" Range("B3:Q82").Select Selection.Copy Sheets("ÊÃÎíÑ").Select Range("B305").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H305").Select Sheets("äÇÕÑ").Select Application.CutCopyMode = False Range("H3:K3").Select ActiveSheet.Range("$A$1:$A$39").AutoFilter Field:=1 Sheets("ÊÃÎíÑ").Select Range("D24,D68,D112,D162,D217,D272,D321").Select Selection.ClearContents Range("H3").Select Application.ScreenUpdating = True End Sub

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

السلام عليكم مرفق ملف ايجارات فيه صفحات باسم العمارة وفيه كشف السكان اريد ترحيل السكان المتأخرين عن الدفع الي صفحه باسم المتأخرين ولكن كل السكان العمارة في كشف مستقل بالمتأخرين فقط كما منسق بالصفحه ويوجد كود ترحيل بالفعل ولكن طويل جدااا ولا يشمل بعض الصفحات شكرا الايجارات - ايهاب .xlsm

جزاك الله كل خير استاذنا الغالي

للرفع

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

الاخوة الاعزاء يوجد ملف مرفق به كود حفظ الورقه النشطه الي pdf ولكن اريد تغير مسار الحفظ الي ملف بعيد عن الملف وعدم ظهور قائمه الحفظ عند الضغط علي زر الحفظ يقوم بحف الملف في مسار اخر في :D بدون ظهور قائمه الحفظ شكرا مقدماsave to pdf.xlsm

اخي الكريم نبيل كود ممتاز ويعمل المطلوب ولكن فيه بعض العقبات طول الكود وصعوبه تعقبه وامكانيه اضافه الصفحات الاخري وشكرا

Sub RentLate() Dim c As Range Dim ws As Worksheet, Sh As Worksheet Dim p As Long p = 5 Set ws = Sheets("المتأخرين") For Each Sh In Worksheets If Sh.Name <> "المتأخرين" Then For Each c In Sh.Range("D6:D" & Sh.Range("D" & Rows.Count).End(xlUp).Row) If c.Value > 0 And c.Value < 1000 Then p = p + 1 ws.Cells(p, 1) = p - 5 ws.Cells(p, 3) = c.Offset(0, 12) ws.Cells(p, 4) = c.Offset(0, 11) ws.Cells(p, 5) = c.Offset(0, 10) ws.Cells(p, 6) = c.Offset(0, 9) ws.Cells(p, 7) = c.Offset(0, 8) 'ws.Cells(p, 8) = c.Offset(0, 7) 'ws.Cells(p, 9) = c.Offset(0, 6) ws.Cells(p, 10) = c.Offset(0, 5) ws.Cells(p, 11) = c.Offset(0, 3) ws.Cells(p, 12) = c.Offset(0, 0) ws.Cells(p, 13) = c.Offset(0, -1) ws.Cells(p, 2) = c.Worksheet.Name End If Next End If Next End Sub شكرا اخي الكريم الكود كده يفي بالغرض ولكن لو امكن اضافه حذف النطاق قبل تنفيذ الكود لكي تكون البيانات محدثه

اخي الكريم مطلوب ترحيل كامل الصف للمستأجر مع اسم الصفحه او خلايا معينه مثل رقم الشقه تاريخ الانتهاء وعدد ايام التأخير والايجار ورقم الجوال Sub RentLate() Dim c As Range Dim ws As Worksheet, Sh As Worksheet Dim p As Long p = 5 Set ws = Sheets("المتأخرين") For Each Sh In Worksheets If Sh.Name <> "المتأخرين" Then For Each c In Sh.Range("D6:D" & Sh.Range("D" & Rows.Count).End(xlUp).Row) If c.Value > 0 And c.Value < 1000 Then p = p + 1 ws.Cells(p, 1) = p - 5 ws.Cells(p, 2) = c.Offset(0, 12) ws.Cells(p, 3) = c.Worksheet.Name End If Next End If Next End Sub

اخي الكريم شكرا علي مجهودك لكن الكود يقوم بترحيل الغير متأخرين ( المتأخرين يتم تحديدهم عن طريق العمود d الذي به عدد ايام التأخير ) ويقوم بجلب كل الصف وليس الاسم فقط

مطلوب ترحيل كل المستأجرين المتأخرين في كل الصفحات الي صفحه واحده ويكتب جنب كل مستأجر اسم الصفحه التي تم ترحيله منها حتي يتم معرفه اسم المستأجر واسم العمارة وشكرا الايجارات (2).xlsm

الكود الثاني فيه سطر If ActiveSheet.Name <> My_Sheet.Name Then GoTo Exit_Me

الكود الاول يقوم باستدعاء الكودين الثاني والثالث الثالث اسمه تحويل يعمل جيدا المشكله في الكود الثاني لا يعمل مع الاستدعاء من خلال الكود الاول ولكنه يعمل منفصل

اخي الكريم لا يعمل الكود الثالث الكود الاول Sub ehab1() Dim my_sh As Worksheet: Set my_sh = Sheets("سندات القبض") Dim Sanad As Worksheet: Set Sanad = Sheets("سند قبض") X = my_sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 With my_sh.Range("a" & X) '.Value = Sanad.[d5].Value .Offset(0, 1).Value = Sanad.[h4].Value .Offset(0, 2).Value = Sanad.[d5].Value .Offset(0, 3).Value = Sanad.[g7].Value .Offset(0, 4).Value = Sanad.[e7].Value .Offset(0, 5).Value = Sanad.[c7].Value .Offset(0, 6).Value = Sanad.[a7].Value .Offset(0, 7).Value = Sanad.[d10].Value .Offset(0, 8).Value = Sanad.[a10].Value .Offset(0, 9).Value = Sanad.[i9].Value .Offset(0, 10).Value = Sanad.[i12].Value .Offset(0, 11).Value = Sanad.[i13].Value .Offset(0, 12).Value = Sanad.[i14].Value .Offset(0, 13).Value = Sanad.[i15].Value .Offset(0, 14).Value = Sanad.[i16].Value End With With Sanad 'MsgBox ("تم الحفظ") End With copy_data_Salim tahwiell End Sub الكود الثاني Sub copy_data_Salim() Dim My_Sheet As Worksheet Set My_Sheet = Sheets("سندات القبض") Dim Target_Sh As Worksheet If ActiveSheet.Name <> My_Sheet.Name Then GoTo Exit_Me Dim laste_row% Dim Const_Srting$: Const_Srting = "تم الترحيل" Dim k%, m%, i%, t% Dim Source_Array() ReDim Source_Array(1 To 11) Source_Array = Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "N") Dim Target_Array() ReDim Target_Array(1 To 11) Target_Array = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M") k = My_Sheet.Cells(Rows.Count, 2).End(3).Row On Error Resume Next For i = 2 To k m = My_Sheet.Cells(i, Columns.Count).End(1).Column If My_Sheet.Cells(i, "q") = Const_Srting Then GoTo Next_I Set Target_Sh = Sheets(My_Sheet.Cells(i, "P") & "") laste_row = Target_Sh.Cells(Rows.Count, 3).End(3).Row + 1 For t = LBound(Source_Array) To UBound(Source_Array) Target_Sh.Cells(laste_row, Target_Array(t)) = _ My_Sheet.Cells(i, Source_Array(t)) Next My_Sheet.Cells(i, "Q") = Const_Srting Next_I: Next Exit_Me: Erase Source_Array: Erase Target_Array Application.ScreenUpdating = True End Sub الكود الثالث Sub tahwiell() 'نقل البيانات Application.Calculation = xlManual Dim FS, FR, TS, TR FS = "سند قبض" FR = "a10" TS = Sheets(FS).Range("A7") TR = Sheets(FS).Range("i26") Sheets(FS).Range(FR).Copy Sheets(TS).Range(TR).PasteSpecial Paste:=xlPasteValues Application.Calculation = xlAutomatic ActiveSheet.EnableSelection = xlUnlockedCells End Sub

يوجد كود قمت بعمل استدعاء لكود اخر عن طريق CALL وقمت بعمل استدعاء كود اخر ثالث عن طريق CALL لكن كود يعمل وكود لا يعمل

لا حول ولا قوة الا بالله

اللهم صلي علي سيدنا محمد