الـعيدروس

السلام عليكم الاخ الفاضل admbrk مابين IF و End IF حط اي امر سوف ينفذ مثلا Sub Test_A() If Range("H100").Value = 5 Then Columns("g").EntireColumn.Hidden = True Range("H100").Value = 100 ' ضع اي امر حينفذ ' ' ' End If End Sub

السلام عليكم ماعليك سوى حذف الاسطر التاليه من الكود او تضليلها بعلامة حرف "ط" With Range("G2").Resize(Cells(Rows.Count, 7).End(xlUp).Row, 7) .Interior.Color = xlNone .ClearComments End With

السلام عليكم هذا التعديل بعد اضافة عرض عداد الصفحات الذي اشار اليه اخي الحبيب أبو أنس حاجب حفظه الله Sub P_A() Application.ScreenUpdating = False With ActiveSheet With .PageSetup .PrintTitleRows = "$1:$1" .CenterFooter = "صفحة &P من &N" .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With With .Range("A1:I60000") .Select .AutoFilter .AutoFilter Field:=2, Criteria1:=">""", Operator:=xlAnd ActiveSheet.PrintPreview .AutoFilter: [A1].Select End With End With Application.ScreenUpdating = True End Sub

السلام عليكم جرب هكذا Sub A_D() Dim i, j, k, z, h As Long j = 1 z = 1 k = ActiveSheet.UsedRange.Rows.Count For i = 1 To k If (i Mod j = 0) Then Cells(i, 1).Offset(1, 0).EntireRow.Delete End If Next i Range("a1").Select End Sub

السلام عليكم هذا التعديل على الكود ليبدء من أول سطر Sub صف_فارغ() Dim i, j, k, z, h As Long j = Int(InputBox("enter the interval")) z = 1 k = ActiveSheet.UsedRange.Rows.Count For i = 1 To k + z Step 1 If (i Mod j = 0) Then ActiveSheet.Cells(i + z, 1).Select Selection.EntireRow.Insert z = z + 1 End If Next i Range("a1").Select End Sub

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

السلام عليكم هذا ماتريده With Sheets("sheet1") If .Range("a1").Value = "5" And .Range("h100").Value = 100 Then ' تنفيذ الامر اذا تحققت الشرطين مع بعض وإلا لن ينفذ الامر End If End With

السلام عليكم استاذ الحبيب عبدالله باقشير جزاك الله كل خير على مرورك الكريم وكلماتك الطيبه مرورك شرف كبير اخي الفاضل abouelhassan اذا تريد اسهل طريقة تحدد قيمة البحث في خليه معينه جرب المرفق A_2.rar

السلام ليكم طلبك معقد بالطريقة التي تريدها ولاكن جرب المرفق وبه زر لتنفيذ الكود تكتب القيمة التي تريد البحث عنها ثم انتر وبعدها تضغط المسطره يحدد الخليه ويعمل عليها لون A_1.rar

السلام عليكم تفضل وعلى الكود شرح مبسط عله يفيدك لتعدل الكود بما يناسب عملك Sub P_A() Application.ScreenUpdating = False With ActiveSheet With .PageSetup .PrintTitleRows = "$1:$1" ' تثبيت عنوان رأس كل صفحة والذي هو أول صف .Zoom = False ' تفعيل مربع ملاءمة الصفحة .FitToPagesWide = 1 ' 1 = تفعيل ملاءمة عرض الصفحات 0 = عدم تفعيل ملاءمة عرض الصفحات .FitToPagesTall = False ' False = عدم تفعيل ملاءمة الصفحات طولياً True = تفيل ملاءمة طولياَ أي البيانا في ورقة فقط End With With .Range("A1:I60000") .Select .AutoFilter .AutoFilter Field:=2, Criteria1:=">""", Operator:=xlAnd ActiveSheet.PrintPreview .AutoFilter: [A1].Select End With End With Application.ScreenUpdating = True End Sub وأي تعدي أو اضافه أنا موجود و لا عليك أنا في الخدمه طالما الطلب في حدود المعرفه

السلام عليكم هذا الامر FindControl معامل يبحث في اوامر قوائم الاكسل كل امر له رقم مابين القوسين (ID:=887) 887 = كلمة اظهار في ري كلك على اي عمود Enabled = False في حالة False = تفعيل و True = الغاء الامر وهذا الكود من مشاركه سابقة يعطيك مهام كل رقم في هذا الامر ID FindControl في العمود "B " Public Sub Com_All() Dim R&, Ro%, E% On Error Resume Next With Application .ScreenUpdating = False .EnableEvents = False Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 3)).ClearContents Range("A1:C1") = Array("تسلسل الرقم", "ايدي الامر", "نوعه المسمى") R = 2 For Ro = 1 To 12500 Cells(R, 1) = Application.CommandBars.FindControl(ID:=Ro).Type Cells(R, 2) = Application.CommandBars.FindControl(ID:=Ro).ID '*** Cells(R, 3) = Application.CommandBars.FindControl(ID:=Ro).Caption R = R + 1 Next E = Range("A20000").End(xlUp).Row With Range("C2:C" & E) .VerticalAlignment = xlRight .HorizontalAlignment = xlRight End With For I = E To 2 Step -1 If Range("A" & I).Value = "" Then Range("A" & I).EntireRow.Delete Next .EnableEvents = True .ScreenUpdating = True End With End Sub

السلام عليكم الاخ الحبيب غانا بالامكان اختصار الكود بهذا الشكل Private Sub Worksheet_Change(ByVal Target As Range) If Sheets("sheet1").Range("a1").Value = "5" Then Columns("g").EntireColumn.Hidden = True Application.CommandBars.FindControl(ID:=887).Enabled = False Else Columns("g").EntireColumn.Hidden = False Application.CommandBars.FindControl(ID:=887).Enabled = True End If End Sub

السلام عليكم جرب هكذا Sub Ali_S() With [A13:A24] For R = 1 To .Rows.Count If Not IsEmpty(.Cells(R, 1)) Then .Cells(R, 1).Select: Exit For End If Next End With End Sub

السلام عليكم تفضل Sub P_A() Application.ScreenUpdating = False With ActiveSheet With .PageSetup .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With With .Range("A1:I60000") .Select .AutoFilter .AutoFilter Field:=2, Criteria1:=">""", Operator:=xlAnd ActiveSheet.PrintPreview .AutoFilter: [A1].Select End With End With Application.ScreenUpdating = True End Sub

السلام عليكم تفضل Sub S_A() [A1].End(xlDown).Select End Sub

السلام عليكم الاخ الفاضل ابراهيم ابو ليله تفضل الكود ينفذ ماتريد Sub P_A() Application.ScreenUpdating = False With Range("A1:I60000") .Select .AutoFilter .AutoFilter Field:=2, Criteria1:=">""", Operator:=xlAnd ActiveSheet.PrintPreview .AutoFilter: [A1].Select End With Application.ScreenUpdating = True End Sub

السلام عليكم بعد اذن الاستاذ الحبيب ابو حنين تم عمل معادله بدلا من امر " FileSearch" هو الذي يحدث الخطاء و تعديل بسيط على اكواد حدث "ComboBox1 " هذه الاكواد وعليها التعديل Dim xl As New Excel.Application Dim xlw As Excel.Workbook Dim S_tv$ Private Sub ComboBox1_Click() If ComboBox1.ListIndex = 0 Then MsgBox "هذا الملف رئيسي لا يحتوي على معلومات يرجى اختيار ملف آخر", vbExclamation, "خظأ" Exit Sub End If ComboBox2.Clear S_tv = ThisWorkbook.Path & "\" & ComboBox1.Text Set xlw = Workbooks.Open(S_tv) LR = xlw.Application.Cells(Rows.Count, "A").End(xlUp).Row '+ 1 For t = 2 To LR ComboBox2.AddItem xlw.Application.Cells(t, 1) Next xlw.Close End Sub Private Sub ComboBox2_Click() Set xlw = xl.Workbooks.Open(S_tv) For s = 1 To 8 Me.Controls("TextBox" & s) = xlw.Application.Cells(Val(ComboBox2.Text) + 1, s).Value Me.Controls("Label" & s).Caption = xlw.Application.Cells(1, s) Next xlw.Close End Sub Private Sub UserForm_Initialize() Ali_FileSearch End Sub Private Sub Ali_FileSearch() Dim Path_F$ Path_F = ThisWorkbook.Path M_v = Ali_List(Path_F) If TypeName(M_v) <> "Boolean" Then For i = LBound(M_v) To UBound(M_v) ComboBox1.AddItem M_v(i) Next Else MsgBox "لاتوجد ملفات في المسار :" & Path_F End If End Sub Public Function Ali_List(F_A As String, Optional Fltr_A As String = "*.*") As Variant Dim Te_A As String, A_H As String If Right$(F_A, 1) <> "\" Then F_A = F_A & "\" Te_A = Dir(F_A & Fltr_A) If Te_A = "" Then Ali_List = False Exit Function End If Do A_H = Dir If A_H = "" Then Exit Do Te_A = Te_A & "|" & A_H Loop Ali_List = Split(Te_A, "|") End Function استدعاء بيانات_A.rar

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

السلام عليكم الاخ الفاضل ابو انس حاجب ارجو تجربة المرفق تم تغير المسار الى نفس فولدر ملف الاكسل ربما يكون المشكله في المسار لان الاكواد متوافقه مع 2003 Account Statement.rar

ان كان لديك جهاز به 2007 ارجو تجربة الكود به او من احد الاخوه جزاهم الله خير

ماهو الاوفيس المستخدم لديك 2003 ام 2007 ؟

السلام عليكم الاخ الفاضل goodlife جرب المرفق عله يفي بالغرض "الادخال" تحط الاسم المراد ترجمة ثم تضغط زر الترجمة "الكود ليس من عملي انما اضفت بعض التعديلات عليه من مدخرات التصفح " للاسف لاافتكر صانع الكود تم عمل تعديل للملف ارجو التجربه T_Go.rar

السلام عليكم حمل مرفق مشاركة #6 عملت عليه تعديل طفيف

السلام عليكم حذفت السطر التالي ضعه في مودويل Public Dop_A As MSForms.TextBox

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