الـعيدروس

السلام علكم جرب المرفق ولاتنسى تحط المسار الصحيح لمجلد حفظ الصور Private Const Path_A As String = "C:\Intel" Account Statement New Version20(RMB_2).rar

السلام عليكم الاخ الحبيب أبو أنس حاجب جرب هذا الكود اولا حدد مسار مجلد حفظ الصور في السطر التالي اول الكود Private Const Path_A As String = "C:\Ali\" وهذا الكود لعمل مخطط ونسخ المدى المراد فيه ثم حفظه في المسار كصورة ثم حذف المخطط Public Sub R_pact(Sh As Worksheet, S_Name As String, M_R As Range) Dim R As Excel.Range Dim Chrt_A As Excel.ChartObject With Application .EnableEvents = False .ScreenUpdating = False .DisplayAlerts = False Set R = M_R R.CopyPicture xlScreen, xlPicture Set Chrt_A = ActiveSheet.ChartObjects.Add(0, 0, R.Width + 10, R.Height + 10) Chrt_A.Chart.Paste Re_es Chrt_A.Chart.Export Path_A & S_Name & ".PNG" Chrt_A.Delete .EnableEvents = True .ScreenUpdating = True .DisplayAlerts = True End With Set Chrt_A = Nothing Set R = Nothing End Sub Private Sub Re_es() On Error Resume Next With ActiveChart Do Until .SeriesCollection.Count = 0 .SeriesCollection(1).Delete Loop End With End Sub استدعاء الكود السطر في كود الاستاذ القدير خبور خير في زر الطباعه عن طريق الفورم Private Sub ButtonPrint_Click() Dim wo As Worksheet Dim Ctrl As Control Dim I As Integer ''''''''''''''''' For Each Ctrl In Me.FrameList.Controls If Ctrl.Value Then I = I + 1 If I = 1 Then Me.Hide Set wo = ActiveWorkbook.Worksheets(CStr(Ctrl.Name)) wo.Activate kh_print_out wo '************************************************************************************ ' هذا سطر استدعاء الكود R_pact wo, wo.Name, wo.Range("A5:V" & wo.Cells(Rows.Count, 2).End(xlUp).Row) '************************************************************************************ End If Next Set wo = Nothing If I Then Unload Me End Sub وهذا ملفك السابق وبه الاكواد ارجو تجربه الملف واي ملاحظات او تعديل انا موجود Sav_Imag_Ali.rar

السلام عليكم جرب هذا الكود Sub طباعة() Dim a, x x = Cells(Rows.Count, 2).End(xlUp).Row a = "A5:O" & x Range(a).SpecialCells(xlCellTypeVisible).PrintOut End Sub

السلام عليكم احذف السطر التالي من حدث ListBox1_DblClick .TextBox1 = "": .TextBox2 = "" ليصير كالتالي Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) With UserForm2 Dop_A.Value = Me.ListBox1.Column(0) Unload Me Set Dop_A = Nothing End With End Sub

السلام عليكم الاخ الفاضل إبراهيم ابوليله السموحه على التأخير لانشغالي وبخصوص طلبك تفضل المرفق جرب وابلغني بالنتائج بحث فى الفورم.xlsm_A3.rar

السلام عليكم جرب هكذا Sub ChangeToZero() ActiveSheet.Unprotect Dim t As Range Application.ScreenUpdating = False For Each t In Range("L6:L60000") If t.Value >= -0.005 And t.Value <= 0.005 And Not IsEmpty(t.Value) Then t.Value = 0 If Abs(Int(t)) <= 0.005 And Not IsEmpty(t.Value) Then t.Value = 0 Next Application.ScreenUpdating = True ActiveSheet.Protect End Sub

السلام عليكم عظم الله اجركم واحسن عزاكم وادخل فقيدكم الفردوس الاعلى ان شاء الله وان لله وانا اليه راجعون

السلام عليكم الاستاذ الكبير عبدالله باقشير مرورك شرف كبير واعتز به الاخ الحبيب سعد عابد كلنا نتعلم من بعض جزاك الله كل خير الاخ الفاضل khhanna جزاك الله خير على اثراء الموضوع وهذا تعديل بسيط لعمل Hyperlink للوصول لخلايا الارتباط على حده في جميع الاوراق Sub Show_L() Dim r, a Dim cell As Range Dim Sh As Worksheet r = 1 For Each Sh In ThisWorkbook.Worksheets For Each cell In Sh.UsedRange If Left(cell.Formula, 1) = "=" And InStr(cell.Formula, "[") > 1 Then With ActiveSheet With .[A1] .Value = "مراجع خلاياالإرتباط" .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter End With With .Cells(.Rows.Count, 1).End(xlUp)(2, 1) .Value = Sh.Name & "!" & cell.Address .Hyperlinks.Add Anchor:=.Offset(0, 0), Address:="", SubAddress:=(Sh.Name) & "!" & (cell.Address) End With End With End If Next cell Next Sh End Sub

السلام عليكم الاخ الحبيب الشهابي حفظك الله اشكرك من اعماق قلبي على كلماتك الطيبه ومروك العطر بخصوص ماطلبته جرب الكود التالي Sub Show_L() Dim r, a Dim cell As Range r = 1 For Each cell In ActiveSheet.UsedRange If Left(cell.Formula, 1) = "=" And InStr(cell.Formula, "[") > 1 Then a = a & cell.AddressLocal & vbNewLine 'Cells(r, 1) = cell.AddressLocal ' لاظهار الخلايا المرتبطه في عمود معين 'r = r + 1 End If Next cell MsgBox a End Sub وهكذا لعرض مسارات الملفات المرتبطه في العمود "A" Sub V_link() Dim V As Variant Dim i As Long V = ActiveWorkbook.LinkSources(xlExcelLinks) If Not IsEmpty(V) Then For i = 1 To UBound(V) Cells(i, 1).Value = V(i) Next i End If Exit Sub End Sub او بهذه الطريقة لفتح الملفات المرتبطه مباشره Sub opn_link() Dim V As Variant Dim i As Long V = ActiveWorkbook.LinkSources(xlExcelLinks) If Not IsEmpty(V) Then For i = 1 To UBound(V) Workbooks.Open Filename:=V(i) Next i End If Exit Sub End Sub

السلام عليكم اخي الحبيب سعد عابد اشكرك جزيل الشكر على مرورك العطر وكلماتك الطيبه الاخ الفاضل إبراهيم ابوليله جرب المرفق عله ماتريد بحث فى الفورم.xlsm_A2.rar

السلام عليكم تفضل اخي ابراهيم بحث فى الفورم.xlsm_A1.rar

السلام عليكم فرضا الجدول "A2:D10" والكلمة المراد البحث عنها في "E2" والقيمة النتيجة للعمود الثالث من النطاق استخدم هذه المعادله =IF(ISERROR(VLOOKUP($E2;$A$2:$D$10;3;FALSE));VALUE(VLOOKUP(TEXT($E2;0);TEXT($A$2:$D$10;0);3;FALSE));VLOOKUP($E2;$A$2:$D$10;3;FALSE)) Vluk_A.rar

السلام عليكم تفضل هذا كود دالة معرفة Public Function Rev_Ali(Text As String) Rev_Ali = StrReverse(Text) End Function بعد ادراج الكود في مودويل تستخدم المعادلة كالتالي =Rev_Ali(A4) الطلب.xlsx_A.rar

السلام عليكم ان كان المصنف ليس به ارتباطات اي بمعنى ليس بحاجة الارتباطات للمصنف الطريقة الاولى من اعدادات خيارات الاكسل ثم مركز التوثيق ثم اعدادات مركز التوثيق ثم المحتوى الخارجي ثم اعدادات الامان لإرتباطات المصنف ( حفز على تعطيل التحديث التلقائي لإرتباطات المصنف ) طريقة اخرى إستخدم هذا الكود لحذف الارتباطات Public Sub Delet_Link() Dim Sh As Worksheet For Each Sh In Worksheets Sh.Cells.Hyperlinks.Delete Next Sh End Sub اوهذا الكود End Sub Sub Celr_Link() Dim cell As Range For Each cell In ActiveSheet.UsedRange If Left(cell.Formula, 1) = "=" And InStr(cell.Formula, "[") > 1 Then cell.Value = cell.Value End If Next cell End Sub

السلام عليكم الطلب غير واضح المللف الرئيسي الاعمدة تختلف عن الملف الاخر ماهي الاعمدة المراد جلب بياناتها من الملف الرئيسي ؟؟ وأين هو شرط الرقم الوظيفي ؟

السلام عليكم هذا طلبك بزيادة المدى الى عمود "F" باالاكواد تحويل.xls_A.rar

السلام عليكم جرب هذا التعديل Sub ChangeToZero() ActiveSheet.Unprotect Dim t As Range Application.ScreenUpdating = False For Each t In Range("L6:L60000") If t.Value <= -0# And Not IsEmpty(t.Value) Then t.Value = 0 If Abs(Int(t)) <= 0.005 And Not IsEmpty(t.Value) Then t.Value = 0 Next Application.ScreenUpdating = True ActiveSheet.Protect End Sub

السلام عليكم جرب هذا الكود Public Sub Ali_Tr() C = 8 For Each R In Range("A1:D3") If C Mod 9 Then i = i + 1: C = 8 Cells(i, C) = R: C = C + 1 Next End Sub

السلام عليكم وهكذا برضه =CONCATENATE(A2;TEXT(B2;"yyyy/mm/dd"))

السلام عليكم تفضل بحث فى الفورم.xlsm_A.rar

السموحه منك استاذ احمد لم ارى ردك الاكثر من رائع الا بعد ارسال المشاركه

السلام عليكم ربما هكذا Sub report1() On Error Resume Next Dim A As Range, B As Range Application.ScreenUpdating = False Set A = Sheets("report").[G3] Set B = Sheets("report").[J3] For R = 5 To Sheets("مشتريات").[b10000].End(xlUp).Row If Sheets("مشتريات").Cells(R, 6) = Sheets("report").[c3] Then If Sheets("مشتريات").Cells(R, 5) >= A And Not IsEmpty(A) Then GoTo 0 If Sheets("مشتريات").Cells(R, 5) <= B And Not IsEmpty(B) Then GoTo 0 With Sheets("report").[b10000].End(xlUp) .Offset(1, 0) = Sheets("مشتريات").Cells(R, 2) .Offset(1, 1) = Sheets("مشتريات").Cells(R, 3) .Offset(1, 2) = Sheets("مشتريات").Cells(R, 4) .Offset(1, 3) = Sheets("مشتريات").Cells(R, 5) .Offset(1, 4) = Sheets("مشتريات").Cells(R, 7) .Offset(1, 5) = Sheets("مشتريات").Cells(R, 8) .Offset(1, 6) = Sheets("مشتريات").Cells(R, 9) .Offset(1, 7) = Sheets("مشتريات").Cells(R, 10) End With End If 0: Next Application.ScreenUpdating = True End Sub

السلام عليكم طلبك غير واضح اريد عند الضغط على اللنك g2 الخاص بالخلية الخليه المعنيه فارغه وليس بها اي لينك وعند الضغط على اللينك ماذا تريد ان يظهر في خانة الاسم في الفورم ؟؟

السلام عليكم جرب هذا الكود في مودويل Option Explicit Const C_A As String = "ALL_SH" Sub C_AL() On Error Resume Next With Application .ScreenUpdating = False .EnableEvents = False Dim SH As Worksheet Worksheets.add(After:=Worksheets(Worksheets.Count)).Name = C_A With ActiveSheet .Range("A1").Value = "أسماء الصفحات" .Range("B1").Value = "لينك الصفحات" .Columns("A:B").EntireColumn.AutoFit For Each SH In ThisWorkbook.Worksheets If SH.Name = C_A Then GoTo 1 With .Columns(1).Rows(65536).End(xlUp) .Offset(1, 0) = SH.Name .Offset(1, 1).FormulaR1C1 = "=HYPERLINK(""#'"" & RC[-1] & ""'!A1"", ""اذهب للورقة"")" End With SH.Range("A1").Formula = "=HYPERLINK(""#ALL_SH!A1"",""ALL_SH"")" 1 Next SH End With .ScreenUpdating = True .EnableEvents = True End With End Sub

السلام عليكم جرب هذا الكود Public Sub ali_Su() Dim Rt As Range Dim Sr As Worksheet Set Sr = ورقة2 ActiveSheet.Unprotect Sr.Unprotect With Application .EnableEvents = False .ScreenUpdating = False With ActiveSheet .Rows("5:65536").Sort Key1:=.Cells(5, 21), Order1:=xlDescending, Header:=xlNo .Cells(5, 21).HorizontalAlignment = xlRight E = Sr.Cells(Rows.Count, 1).End(xlUp).Row + 1 For Each Rt In .Range("A5:A" & .Cells(Rows.Count, 1).End(xlUp).Row) If Rt.Value > "" And .Cells(Rt.Row, 21) = 0 Then Range(Cells(Rt.Row, 1), Cells(Rt.Row, 21)).Copy Sr.Cells(E, 1).PasteSpecial xlPasteValues E = E + 1 R = R & "," & Cells(Rt.Row, 1).Address Application.CutCopyMode = False End If Next Ae = Mid(R, 2, Len(R)) Range(Ae).EntireRow.Delete Shift:=xlUp .Rows("5:65536").Sort Key1:=.Cells(5, 21), Order1:=xlDescending, Header:=xlNo .Cells(5, 21).HorizontalAlignment = xlRight End With .EnableEvents = True .ScreenUpdating = True End With Sr.Protect ActiveSheet.Protect End Sub