الـعيدروس

السلام عليكم استاذي الحبيب دغيدي حفظك الله اعتقد الكود التالي يستخرج الهارد بصورة أدق حيث انه يعطيك رقمين في خلية A1 و A2 الأول تنسخه مع الفراغ إن وجد في الخليه وتلصقه في المتغير الثابت والثاني تجاهله Private Const A As String = "هنـــا" هذا الكود لإستخراج رقم الهارد Sub Ali_HD() Dim Ali_Obj As Object Dim Ali_Wm As Object Dim Ali() As Variant Dim i%, Csr%, T& Set Ali_Wm = GetObject("WinMgmts:") For Each Ali_Obj In Ali_Wm.InstancesOf("Win32_PhysicalMedia") ReDim Preserve Ali(0 To i) Ali(i) = Ali_Obj.SerialNumber i = i + 1 Next T = 1 For Csr = LBound(Ali) To UBound(Ali) Cells(T, "A") = Ali(Csr) T = T + 1 Next Erase Ali End Sub وهذا الكود السابق في حدث Thisworkbook Private Const A As String = "A12335644" Private Const B As String = "Har Othr1" Private Const C As String = "Har Othr2" Private Sub Workbook_Open() Dim s As String With GetObject("winmgmts:\\.\root\CIMV2") For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48) s = s & itm.SerialNumber Next itm End With Debug.Print "C :" & C & " " & "s :" & s If s = A Or s = B Or s = C Then MsgBox "تم مطابقة الهارد بنجاح ", vbInformation, "تفضل بالدخول" Else MsgBox "هذا البرنامج يعمل على أجهزة معينه فقط", vbInformation, "سيتم إغلاق البرنامج" With ActiveWorkbook .Close .Saved = True End With Exit Sub End If End Sub

السلام عليكم الاخ الاستاذ أبو حنين حفظك الله عمل متقن وجميل جزاك الله خير وجعل اعمالك في موازين حسناتك ان شاء الله تقبل مروري

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

السلام عليكم جرب هذا التعديل ولو لم يفي بالغرض أرجو توضيح الطلب Sub myfilter() Dim lastrow As Long Application.ScreenUpdating = False With Sheets(1) .AutoFilterMode = False lastrow = Range("a" & Rows.Count).End(xlUp).Row Range("A1:D22").Select Selection.AutoFilter ActiveSheet.Range("$A$1:$D$22").AutoFilter Field:=4, Criteria1:=[F7], Operator:=xlOr, Criteria2:=[F9] .Range("a2:d" & lastrow).Copy With Sheets(Range("F3").Value) .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Value = Empty .Range("a2").PasteSpecial xlPasteValues End With .AutoFilterMode = False Application.CutCopyMode = False End With Application.ScreenUpdating = True End Sub

السلام عليكم جرب هكذا أرقام الأجهزة الفعليه تحطها في المتغيرات الثابته A,B,C غيرها لايعمل البرنامج Private Const A As String = "A12533225" Private Const B As String = "B15223662" Private Const C As String = "TOSHIBA MK6476GSX" Private Sub Workbook_Open() Dim s As String With GetObject("winmgmts:\\.\root\CIMV2") For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48) s = s & itm.Model Next itm End With If s = A Or s = B Or s = C Then MsgBox "تم مطابقة الهارد بنجاح ", vbInformation, "تفضل بالدخول" Else MsgBox "هذا البرنامج يعمل على أجهزة معينه فقط", vbInformation, "سيتم إغلاق البرنامج" With ActiveWorkbook .Close .Saved = True End With Exit Sub End If End Sub

السلام عليكم تفضل جرب الكود بعد التعديل ولاتنسى مسار ملف الـ Text Public Sub ali_T() Dim r As Range, A, Ali_Path$ Str_A = "[Serv_" [B1].ColumnWidth = 64.15 Rt = 1 Ali_Path = "C:\Ali\gg.txt" '*************************************** ' C:\Ali\gg.txt المسار ' غيره حسب مسار ملف التكست والمسمى Open Ali_Path For Output As #1 '*************************************** With Application .ScreenUpdating = False .EnableEvents = False For Each r In Range("A1:A256") If Not IsEmpty(r) Then A = Str_A & Rt & "]" & Chr(10) & r.Text & Chr(10) Cells(Rt, 2) = A Print #1, Str_A & Rt & "]" & vbCrLf & r.Text & vbCrLf Rt = Rt + 1 End If Next .ScreenUpdating = True .EnableEvents = True End With Close #1 End Sub

السلام عليكم الكود يعمل مثل ماتفضل بشرحه [color=#008000][size=5][font='times new roman', times, serif][b]ثانياً : يتم نسخ كل الصفوف التي تلي اسم الموظف الذي تم نقله حتى الصف 400 فقط وليس لنهاية البيانات لأنها ثابتة ويتم لصقها على الموظف المنقول في صفحة البيانات وبذلك نتفادى أي أخطاء الناتجة من الحذف وباقي الأوراق لا يتم التعديل بها[/b][/font][/size][/color] وهذا تعديل بسيط لنسخ المعادلات Type S_Ali V_A As Variant D_A As String End Type Public Work As Workbook Public Ali_Sh As Worksheet Public Ali_Rn() As S_Ali Public Sub Ali_T() Dim Sh As Worksheet, S As Worksheet Dim R As Range, Rn As Range, Rr%, E, EE Dim Rtt As Range Set R = Range("G2") Set S = ورقة3 Set Sh = ورقة2 Set Rn = Sh.Range("B6:IP" & Sh.Cells(Rows.Count, 2).End(xlUp).Row) On Error Resume Next With Rn For Rr = 1 To .Rows.Count If .Cells(Rr, 1).Value = R.Value Then .Rows(Rr).Copy S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteFormulasAndNumberFormats .Rows(Rr).ClearContents a = .Cells(Rr, 1).Row Exit For End If Next With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual b = Sh.Cells(Rows.Count, 2).End(xlUp).Row With Sh Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 250).Address) If TypeName(Rtt) <> "Range" Then Exit Sub ReDim Ali_Rn(Rtt.Count) Set Work = ActiveWorkbook Set Ali_Sh = Sh I = 0 For Each CE In Rtt I = I + 1 Ali_Rn(I).D_A = CE.Address Ali_Rn(I).V_A = CE.Formula Next CE .Range(.Cells(a, 2).Address, .Cells(b, 250).Address).ClearContents End With .Calculation = xlCalculationManual .EnableEvents = True .ScreenUpdating = True End With Application.CutCopyMode = False Call Ali_Set End With End Sub Sub Ali_Set() With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual Work.Activate Ali_Sh.Activate For I = 1 To UBound(Ali_Rn) Range(Ali_Rn(I).D_A).Offset(-1, 0).Formula = Ali_Rn(I).V_A Next I Range(Cells(6, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data" sss.Activate .Calculation = xlCalculationManual .ScreenUpdating = True .EnableEvents = True End With Exit Sub End Sub

السلام عليكم انسخ هذا الكود لحدث الورقة تعتمد تسمية الشيت النشط حسب قيمة خلية " A1 " بإمكانك تغير أي خليه تريد Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$A$1" Then ActiveSheet.Name = Target.Text End Sub

السلام عليكم استخدم هذه الداله المعرفه 1 يعطيك الشرط الاول 2 يعطيك الشرط الاخر بالشكل التالي تعطيك المعادله "2105" =Ali_F(D2;2) Public Function Ali_F(R As Range, V As Integer) As Long Dim A, B B = Mid(R.Formula, InStr(R.Formula, "+") + 1) If Val(V) = 1 Then A = Mid(R.Formula, InStr(R.Formula, "=") + 1, 5) ElseIf Val(V) = 2 Then A = Mid(R.Formula, Right$(InStr(R.Formula, "+"), Len(B))) End If Ali_F = A End Function

السلام عليكم Sub adel3() Range("A9:g9").AutoFilter Range("NN").AutoFilter , field:=2, Criteria1:="*" & Left(Range("B9"), Len(Range("B9"))) & "*" Range("b9").Clear With Range("b9") .Font.Name = Andalus .Font.Size = 16 .Font.Bold = True .Font.Color = 255 .Interior.Color = 65535 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End Sub

وعليكم السلام ورحمة الله وبركاته لاشكر على واجب اخي fzsss ارجو منك ارفاق مثال من ملفك الاصلي بيانات وهميه كي اعرف المدى المطلوب تنفيذ الكود عليه وان شاء الله يتم عمل اللازم وتوضيح ماتم تعديله على الكود كي تعدل في حال تغير المدى

السلام عليكم حسب فهمي للطلب اولا في هذا السطر حط مسار ملف Text قبل تنفيذ الكود Ali_Path = "C:\Ali\gg.txt" وهذا الكود في مودويل Public Sub ali_T() Dim r As Range, A, Ali_Path$ Str_A = "[Serv_" [B1].ColumnWidth = 64.15 Rt = 1 Ali_Path = "C:\Ali\gg.txt" '*************************************** ' C:\Ali\gg.txt المسار ' غيره حسب مسار ملف التكست والمسمى Open Ali_Path For Output As #1 '*************************************** With Application .ScreenUpdating = False .EnableEvents = False For Each r In Range("A1:A256") If Not IsEmpty(r) Then A = Str_A & Rt & "]" & Chr(10) & r.Text & Chr(10) _ & "." & Chr(10) & "." & Chr(10) & Str_A & Rt & "]" & Chr(10) & r.Text Cells(Rt, 2) = A Print #1, Str_A & Rt & "]" & vbCrLf & r.Text & vbCrLf & "." & vbCrLf _ & "." & vbCrLf & Str_A & Rt & "]" & vbCrLf & r.Text & vbCrLf Rt = Rt + 1 End If Next .ScreenUpdating = True .EnableEvents = True End With Close #1 End Sub الكود ينسخ بيانات العمود A ويضيف عليها ماطلبت وينسخها الى ملف Text المشار اليه بالمسار اول الكود و في العمود B

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

السلام عليكم وضحت لك الاسطر التي تتغير اذا تغير المدى حسب الملف السابق Public Sub Ali_T() Dim Sh As Worksheet, S As Worksheet Dim R As Range, Rn As Range, Rr%, E, EE Dim Rtt As Range Set R = Range("G2") Set S = ورقة3 Set Sh = ورقة2 '*************************************************************** ' المدى المحدد من عمود B6:X ' بإمكانك تغيره حسب الأعمدةالمراده مثال B6:IP Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row) '*************************************************************** On Error Resume Next With Rn For Rr = 1 To .Rows.Count If .Cells(Rr, 1).Value = R.Value Then .Rows(Rr).Copy S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues .Rows(Rr).ClearContents a = .Cells(Rr, 1).Row Exit For End If Next With Application .ScreenUpdating = False .EnableEvents = False b = Sh.Cells(Rows.Count, 2).End(xlUp).Row With Sh '*************************************************************** 'IP'الى 250 الذي هو عمود 'X' تغير المدى حسب المراد مثلا بدل 24 الذي هو Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 24).Address) '*************************************************************** If TypeName(Rtt) <> "Range" Then Exit Sub ReDim Ali_Rn(Rtt.Count) Set Work = ActiveWorkbook Set Ali_Sh = Sh i = 0 For Each CE In Rtt i = i + 1 Ali_Rn(i).D_A = CE.Address Ali_Rn(i).V_A = CE.Formula Next CE '*************************************************************** ' هنا حذف اعمدة البيانات فقط بدون الاعمدة التي بها صيغ ' اذا تغير مدى البيانات في ملفك الاصل غيره من هنا .Range(.Cells(a, 2).Address, .Cells(b, 15).Address).ClearContents '*************************************************************** End With .EnableEvents = True .ScreenUpdating = True End With Application.CutCopyMode = False Call Ali_Set End With End Sub

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

السلام عليكم تفضل جرب هذا الكود Public Rn() As Variant Public Sub Ali() Dim Ali_Ro&, Ali_Co& Dim T%, E%, CC% Ali_Co = 5 Ali_Ro = Cells(Rows.Count, 2).End(xlUp).Row With Range("B5").Resize(Ali_Ro, Ali_Co) ReDim Rn(1 To Ali_Ro, 1 To Ali_Co) For T = 1 To .Rows.Count If CStr(.Cells(T, 1)) <> "" Then E = E + 1 For CC = 1 To Ali_Co Rn(E, CC) = CStr(.Cells(T, CC)) Next End If Next End With Range("B5").Resize(Ali_Ro, Ali_Co).ClearContents Range("B5").Resize(Ali_Ro, Ali_Co).Value = Rn Erase Rn End Sub Ali_Sert.rar

السلام عليكم كل عام وانت بخير fzsss عيدك مبارك وكل سنه وانت بصحه وسلامه إن شاء الله هذا الكود في حدث ورقة " الرئيسية " Private Sub الريئسية_Click() Call Ali_T End Sub وهذه الأكواد في مودويل Type S_Ali V_A As Variant D_A As String End Type Public Work As Workbook Public Ali_Sh As Worksheet Public Ali_Rn() As S_Ali Public Sub Ali_T() Dim Sh As Worksheet, S As Worksheet Dim R As Range, Rn As Range, Rr%, E, EE Dim Rtt As Range Set R = Range("G2") Set S = ورقة3 Set Sh = ورقة2 Set Rn = Sh.Range("B6:X" & Sh.Cells(Rows.Count, 2).End(xlUp).Row) On Error Resume Next With Rn For Rr = 1 To .Rows.Count If .Cells(Rr, 1).Value = R.Value Then .Rows(Rr).Copy S.Range("B" & S.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteValues .Rows(Rr).ClearContents a = .Cells(Rr, 1).Row Exit For End If Next With Application .ScreenUpdating = False .EnableEvents = False b = Sh.Cells(Rows.Count, 2).End(xlUp).Row With Sh Set Rtt = .Range(.Cells(a + 1, 2).Address, .Cells(b, 24).Address) If TypeName(Rtt) <> "Range" Then Exit Sub ReDim Ali_Rn(Rtt.Count) Set Work = ActiveWorkbook Set Ali_Sh = Sh i = 0 For Each CE In Rtt i = i + 1 Ali_Rn(i).D_A = CE.Address Ali_Rn(i).V_A = CE.Formula Next CE .Range(.Cells(a, 2).Address, .Cells(b, 15).Address).ClearContents End With .EnableEvents = True .ScreenUpdating = True End With Application.CutCopyMode = False Call Ali_Set End With End Sub Sub Ali_Set() With Application .ScreenUpdating = False .EnableEvents = False On Error GoTo Err Work.Activate Ali_Sh.Activate For i = 1 To UBound(Ali_Rn) Range(Ali_Rn(i).D_A).Offset(-1, 0).Formula = Ali_Rn(i).V_A Next i Range(Cells(6, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Name = "Data" sss.Activate .ScreenUpdating = True .EnableEvents = True End With Exit Sub Err: MsgBox "Err Not Recv" End Sub *************************************** أرجو من الإدارة تعديل عنوان المشاركة ليدل عن محتواها *************************************** Ali_fzsss_Data_2003.rar Ali_fzsss_Data_2007.rar

جزاكم الله كل خير على مروركم العطر وكلماتكم الطيبه تقبلو تحياتي وشكري

السلام عليكم حط هذا الكود في حدث الورقة Dim R As Range Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Range("A2"), Target) Is Nothing Then Set R = Range("B2:K2") If Target.Value > 0 Then Target.Value = WorksheetFunction.Sum(R) - Target.Value Exit Sub End If End If End Sub

مدام دخلت في الموضوع استاذ عبدالله ماعلينا سوى الانصات والإستمتاع بحلولك النيره ومانحنو سوى تلاميذ في مدرستك حاولت ولم اتوصل لحل

استاذ عبدالله ربما الملفان المعنيه غير متوفره في اوفيس 2003 انا استخدم اوفيس 2007 واعتقد الكود الاخير يعمل على اوفيس 2003

السلام عليكم استاذي الحبيب خبور خير جرب هذه الطريقة Public Sub ali_Sp() Dim Ali_Spec As Object Dim A A = "1 2 3 4 5 6 7 8 9 10" '******************************************* Set Ali_Spec = CreateObject("SAPI.SpVoice") Ali_Spec.Rate = 0 Ali_Spec.Speak " " & A & " ", 0 Set Ali_Spec = Nothing '******************************************* End Sub

استاذ عبدالله حاول تذهب على هذا المسار علامة الويندوز + حرف R "ق" ونسخ هذا المسار C:\Windows\System32\Speech\Common انسخ الملف المرفق بعد فك الضغط وسط المسار وجرب ان شاء الله يمشي الحال sapi.rar

تفضل استاذ عبدالله

السلام عليكم حط هذا الكود في حدث الورقة Private Const Ali_Sta As String = "-" Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Range("E7:E13"), Target) Is Nothing Then If Target.Value > 0 Then Target.Font.Color = RGB(255, 0, 0) Target.Value = Ali_Sta & Target.Value Exit Sub End If End If End Sub