الـعيدروس

هذا الكود فعلا يحدث المعادلات من الموقع الذي اشرت اليه Sub UpdateFormulae() Application.ScreenUpdating = False On Error Resume Next Dim ws As Worksheet Dim rRange As Range Dim curCell As Range Set rRange = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas) For Each curCell In rRange curCell.Select curCell.FormulaR1C1 = curCell.FormulaR1C1 Next Application.ScreenUpdating = True End Sub

السلام عليكم فرضا ان عمود تسجيل البيانات هو B وعمود المسلسل A حط هذا الكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [B:B]) Is Nothing Then If Target.Row = 2 Then Target.Offset(0, -1) = 1 Target.Offset(0, -1).Value = Val(Target.Offset(-1, -1)) + 1 End If End Sub

انا مسحت اوفيس 2007 ونصبت اوفيس 2003 وجربت الكود يعمل 100% جرب المرفقات كنترول 2_A - 2013.part01.rar

تفضل المرفقات في المشاركة السابقه

السلام عليكم جرب هذا الكود Public Sub Al_F() Dim R As Range, R1 As Range On Error Resume Next Dim Rn As Range, Rr As Range Range("D26:I39").ClearContents E = 26 Set Rn = Range("D10:D12") For Each R In Rn If R.Offset(0, 1).Text = [G22].Text Then If IsDate(R) >= IsDate([I21]) And IsDate(R) <= IsDate([I22]) Then With Cells(E, 4) Union(Cells(R.Row, 4), Cells(R.Row, 6)).Copy: _ .PasteSpecial xlPasteValues R.Offset(0, 3).Copy: .Offset(0, 3).PasteSpecial xlPasteValues R.Offset(0, 5).Copy: .Offset(0, 5).PasteSpecial xlPasteValues E = E + 1 End With End If End If Next L_r = Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row For Each R In Range("L9:L13") If R.Offset(0, 1).Text = [G22].Text Then If IsDate(R) >= IsDate([I21]) And IsDate(R) <= IsDate([I22]) Then With Cells(L_r, 4) R.Copy: .PasteSpecial xlPasteValues R.Offset(0, 3).Copy: .Offset(0, 1).PasteSpecial xlPasteValues R.Offset(0, 2).Copy: .Offset(0, 2).PasteSpecial xlPasteValues R.Offset(0, 4).Copy: .Offset(0, 3).PasteSpecial xlPasteValues R.Offset(0, 6).Copy: .Offset(0, 4).PasteSpecial xlPasteValues End With L_r = L_r + 1 End If End If Next Application.CutCopyMode = False End Sub كشف_A.rar

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

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

السلام عليكم جرب المرفق وهو ورقة 13 فقط Ali_Sh_2007.rar Ali_Sh_2003.rar

أولا اشكرك على هذا املف الرائع اما الشريط اضن انه غير موجود في المرفق ارجو التوضيح في اي حدث الكود ؟

السلام عليكم تفضل جرب هذا التعديل Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Ext If Not Intersect(Target, [C:C]) Is Nothing Then Application.ScreenUpdating = False Application.EnableEvents = False If Target = "" Then Exit Sub Target.Offset(0, 1) = "(" & Day(Now) & ")" & " " & "(" & Format(Day(Now), "ddd") & ")" Target.Offset(0, 2) = Now Application.ScreenUpdating = True Application.EnableEvents = True End If Ext: End Sub

ارجو الرد على سؤالي هل برنامج الميزان مسطب على الجهاز الكمبيوتر أم انه جهاز اخر ؟

السلام عليكم جرب هذا الكود لعمل تحديث Public Sub A_Ref() With Application .Volatile False Cells.Replace What:="=", Replacement:="=", LookAt:=xlPart, SearchOrder _ :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End With End Sub

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

بيكون بالشكل التالي Public Sub Ali_Bord() If ActiveCell.Column <> 5 Or ActiveCell.Row < 10 Then Exit Sub On Error Resume Next Dim A_S As Range, A_Ar As Range Dim A_Cel As Range Dim I_Rw%, S_A%, In_A% Set A_S = Selection For Each A_Ar In A_S.Areas For I_Rw = 1 To A_Ar.Rows.Count Step 1 Set A_Cel = A_Ar.Rows(I_Rw) In_A = A_Cel.Row S_A = Cells(In_A, 1).Row Range(Cells(S_A, 1), Cells(S_A, 13)).Borders.ColorIndex = xlNone Next Next If ActiveCell = "" Then Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 13)).Borders.LineStyle = xlNone: Exit Sub Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 13)).Borders.ColorIndex = 1 End Sub

جربت الكود نسخ كل شيء التنسيقات الشرطية موجوده في الملف الجديد ؟

السلام عليكم تفضل Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If WorksheetFunction.CountIf([A1:A20], TextBox1) = 0 Then MsgBox "القيمة المدخلة غير موجودة في النطاق", vbExclamation, "تنبية !" TextBox1.SelStart = 0 TextBox1.SelLength = Len(TextBox1.Text) TextBox1 = "" Cancel = True Else Exit Sub End If End Sub

ارفق صورة لواجهة البرنامج وإن شاء الله نتوصل الى حل

ممكن توضح مالمراد من هذه الفكره !؟

المشار اليه في مرفقك ليس الكود ؟ احذفه !

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

السموحه استاذي الخالدي لم ارى ردك الا بعد المشاركه ماشاء الله عليك أخي الخالدي كودك مختصر ورائع

السلام عليكم تفضل اخي ياسر Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 5 Or Target.Row < 10 Then Exit Sub On Error Resume Next Dim A_S As Range, A_Ar As Range Dim A_Cel As Range Dim I_Rw%, S_A%, In_A% Set A_S = Selection For Each A_Ar In A_S.Areas For I_Rw = 1 To A_Ar.Rows.Count Step 1 Set A_Cel = A_Ar.Rows(I_Rw): In_A = A_Cel.Row: S_A = Cells(In_A, 1).Row Range(Cells(S_A, 1), Cells(S_A, 13)).Borders.ColorIndex = xlNone Next Next If Target = "" Then Range(Cells(Target.Row, 1), Cells(Target.Row, 13)).Borders.LineStyle = xlNone: Exit Sub Range(Cells(Target.Row, 1), Cells(Target.Row, 13)).Borders.ColorIndex = 1 End Sub ارجو التجربه تحياتي

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

السموحه منك لعدم شرحي عن عمل الكود الكود تنسخه الى حدث الورقة وتنقر مرتين على الخليه المراد نسخها الى العمود J الكود ينسخ القيمة ويضيف جمع للقيمة والقيم التي قبلها

السلام عليكم الاخ الفاضل حمادة عمر توصلت لحل يفي بالغرض المشكله هيا الإنتظارفقط لانه الكود بيبحث في جمي ملفات القرص بيأخذ حبتين من الوقت تنسخ الأكواد لحدث الفورم طبعاً حط اسم القرص ونوع الاكسل في اول الكود Private Const Path_A As String = "C:\" Private Const Fr_A As String = ".xls" وهذا الكود Private Const Path_A As String = "C:\" Private Const Fr_A As String = ".xls" Dim W_a As Workbook Dim F_A As Object Dim A_F As Object Dim Rw As Long, Ar() As Variant Private Function Ali_Dir(Nm_Comn As String) Dim Nm_F$ Dim N_d As Long, N_f As Long, Siz_A As Currency On Error Resume Next Set F_A = CreateObject("Scripting.FileSystemObject") With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False ReDim Ar(1 To 1000, 1 To 1) Rw = 1 Nm_F = Nm_Comn & Fr_A Siz_A = Find_A(Path_A, Nm_F, N_d, N_f) If Str(nFiles) = "" Then MsgBox "لايوجد الملف المعني في القرص", vbExclamation, "تنبية !": Exit Function If Str(nFiles) > 1 Then MsgBox "يوجد أكثر من ملف بنفس الاسم في القرص", vbExclamation, "تنبية !": Exit Function ' MsgBox Str(N_d) & " عدد الملف المسماه بنفس الاسم" & Str(N_f) & " في الدليل", vbInformation Cells(1, 205).Resize(1000, 1).Value = Ar Ali_Dir = Cells(1, 205).Text .EnableEvents = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Erase Ar Set F_A = Nothing: Set A_F = Nothing End Function Private Function Find_A(ByVal S_F As String, SF_i As String, N_d As Long, N_f As Long) As Currency Dim T_f As Object, Fil_N As String, T_Fi As Object On Error GoTo Ex_A Set A_F = F_A.GetFolder(S_F) Fil_N = Dir(F_A.BuildPath(A_F.Path, SF_i), vbNormal Or vbHidden Or vbSystem Or vbReadOnly) While Len(Fil_N) <> 0 Find_A = Find_A + FileLen(F_A.BuildPath(A_F.Path, Fil_N)) N_f = N_f + 1 Ar(Rw, 1) = F_A.BuildPath(A_F.Path, Fil_N) Rw = Rw + 1 Fil_N = Dir() DoEvents Wend N_d = N_d + 1 If A_F.SubFolders.Count > 0 Then For Each T_f In A_F.SubFolders DoEvents Find_A = Find_A + Find_A(T_f.Path, SF_i, N_d, N_f) Next End If Exit Function Ex_A: Fil_N = "" Resume Next End Function ويستعدى من حدث الزر فرضا الزر هو CommandButton3 بيكون بالشكل التالي Private Sub CommandButton3_Click() Set W_a = Workbooks.Open(Ali_Dir(CommandButton3.Caption)) Unload Me End Sub ملاحظة مهمه: قبل النقر على الزر أولا قم بالدخول للملف المسمى فتح ثم استدعي الفورم وحاول تفتح أي ملف بعد استدعاء الدالة من كل زر طبعا الكود يفتح الملفات المخفيه والمرفق مطبق الكود على كل زر أرجو التجربه وأي ملاحظه أو تعديل أنا موجود تحياتي فتح.rar