سليم حاصبيا

ارفع ملفاً جديداً يحتوي عما تريد أقله 10 صفوف من البيانات مع النتيجة المتوقعة ( يدوياً)

استبدل هذا السطر في الكود R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7")).Row بهذا R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7"),Lookat:=Xlwhole).Row Xlwhole هنا حرف الـــ L باللغة الانكليزية وليس رقم 1 اذا كان هذا الجواب الكود يفي بالغرض اضغط على افضل اجابة لإغلاق الموضوع

Search By two ways اعرض الملف يمكن عمل بحث في جدول بطريقة الاسم او الرقم صاحب الملف سليم حاصبيا تمت الاضافه 13 يول, 2019 الاقسام معلومات مفيدة

تم ازالة بعض الخلايا المدمجة لحسن عمل الكود مجرد ان تدخل الاسم او الرقم يقوم الكود بعمله واذا كان هناك خطأ يعطيك اشعاراً بذلك الكود Option Explicit Private source_sh As Worksheet Private Target_sh As Worksheet Private Last_row% Private RG_Source As Range Private R1% Rem =====>> created by Salim Hasbaya 13/7/2019 Sub Get_Data_By_name() Set source_sh = Sheets("ورقة2") Set Target_sh = Sheets("ورقة1") Union(Target_sh.Range("D8"), Range("c12").Resize(, 5)).ClearContents Last_row = Application.Max(source_sh.Range("D:D")) + 6 Set RG_Source = source_sh.Range("b6:d" & Last_row) On Error Resume Next R1 = RG_Source.Columns(1).Find(Target_sh.Range("D7")).Row On Error GoTo 0 If R1 = 0 Then MsgBox "DATA nOT FOUND": Exit Sub Else With Target_sh .Range("C12") = .Range("D7") .Range("D8") = source_sh.Cells(R1, "C") .Range("F12") = .Range("D8") .Range("G12") = source_sh.Cells(R1, "D") End With End If End Sub Rem ------------------------------------------- Sub Get_Data_By_Index() Set source_sh = Sheets("ورقة2") Set Target_sh = Sheets("ورقة1") Union(Target_sh.Range("D7"), Range("c12").Resize(, 5)).ClearContents Last_row = Application.Max(source_sh.Range("D:D")) + 6 Set RG_Source = source_sh.Range("b6:d" & Last_row) On Error Resume Next R1 = RG_Source.Columns(2).Find(Target_sh.Range("D8"), lookat:=xlWhole).Row On Error GoTo 0 If R1 = 0 Then MsgBox "DATA NOT FOUND": Exit Sub Else With Target_sh .Range("D7") = source_sh.Cells(R1, "B") .Range("C12") = .Range("D7") .Range("F12") = .Range("D8") .Range("G12") = source_sh.Cells(R1, "D") End With End If End Sub Rem +++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Count = 1 Then Select Case Target.Address Case "$D$7": Get_Data_By_name Case "$D$8": Get_Data_By_Index End Select End If Application.EnableEvents = True End Sub Archive2019.xlsm

ممكن أن يكون المطلوب Khadamat.xlsx

للاسف لا أجيد التعامل مع مع Google Sheet ربما ذلك يتطلب برمجة خاصة داخل ال Google نفسه

اذا كان هذا يلبي الحاجة المطلوبة اضغط على افضل اجابة لاغلاق الموضوع

جرب هذا الملف اعتذر عن ادراج الماكرو بسبب البطء الشديد للنت AUTO_SHOW_HIDE.xlsm

جرب هذا الماكرو Option Explicit Sub Verify_data() With Sheets("ورقة1") Dim my_rg As Range Dim i% Set my_rg = Range("A2", Range("M1").End(4)) For i = 1 To my_rg.Rows.Count If my_rg.Cells(i, 2) = False Then _ my_rg.Cells(i, 7).Resize(, 7) = 0 Next End With End Sub الملف مرفق tajriba.xlsm

لم افهم الاستفسار ارفع ملف يحتوي على مثال عما تريد ان تقوله

لا لزوم للماكرو فقط معادلة في F6 واسحبها نزولاً =ROUND(((C6+D6)*2+E6*3)/6,2) الملف مرفق kaddour1.xlsx

شاهد هذا الفيديو الذي يعطيك مثالاً عن كيفية نسخ الكود الى اي ملف في اكسل بعد الاطلاع عليه قم بنسخ الكود من المشاركة الى النافذة التي تخرج بعد الضغط على Alt+F11 https://www.youtube.com/watch?v=8pfdm7xs3QE

شاهد هذا الفيديو لمعرفة كيفية تشغيل الماكرو https://www.youtube.com/watch?v=9LiIpLIOyLo

فقط اضغط على الزر Run

وهل يجوز ان يكون اسم اي شيت فارغاً ??? حللها بنفسك ولكن لتفادي ظهور هذه الرسالة يمكن اضافة سطر بسيط على الكود (مباشرة قبل عبارة If IsError) السطر المطلوب if Len(my_name)=0 Then Exit Sub

جرب هذا الكود Option Explicit Sub DET_NEW_SHEET() Dim sh As Worksheet Dim arr_sh() Dim k%: k = 1 Dim my_name$ ReDim arr_sh(1 To Sheets.Count) For Each sh In Sheets arr_sh(k) = sh.Name k = k + 1 Next my_name = InputBox("insert sheet name", "Create sheet") If IsError(Application.Match(my_name, arr_sh, 0)) And _ Len(my_name) <= 5 Then Sheets("sheet1").Copy ThisWorkbook.Sheets(Sheets.Count) ActiveSheet.Name = my_name Else MsgBox "This sheet is already exists" & Chr(10) & _ "or the name of sheet is too large" End If Erase arr_sh End Sub

للاسف الكتابة(اقصد لون الخط او حجمه) ليست من محتوى الخلية (مضمون الخلية ممكن ان يكون نص أو رقم أو فراغ)

لا يوجد اي دالة تقوم بتغيير تنسيق الخلايا (لون/ حجم الخط/حدود الخلية الخ..) الدالة تنظر فقط الى محتوى الخلية وليس شكلها الخارجي على أمل ان تقوم شركة مايكروسوفت باشاء هكذا دالة (تقوم بتنسيق الخلايا ) يبقى علينا العمل على هذا الشيء من خلال الـــ VBA فقط ثم خلفية ايه؟ واي خلايا في اي ملف ؟؟؟ ما دام لم ترفع شيئاً للمعاينة

بالنسبة للسؤال الاول (المفروض ان فى رقم 2 التاريخ بدأ من 17-5-2015 والناتج طلع 40 المفروض يطلع 35) في رقم 2 البداية (سنة 2017) الأشهر هي 5 /6 / 7 / 8 / 9 / 10 /11 / 12 أي ما مجموعه 8 أشهر و ليس 7 بالنسبة للسؤال الثاني (المرفق صفحة Correction) تم العمل على ان 1- اذا كان تارخ البداية اكبر من 15 يحتسب نصف الشهر و الا الشهر كاملاً 2-اذا كان تاريخ النهاية اصغر من 15 يحتسب نصف الشهر و الا الشهر كاملاً كل هذا بواسطة المعادلات اما اذا اردت الحل بواسطة الماكرو تجد الحل في الصفحة vba_sh من نفس الملف المرفق الكود Option Explicit Sub get_Salary() Dim Annee%: Annee = [d1] Dim arr_val() Dim i%, ind%, t% Dim def1 As Double, def2 As Double Dim adrs1%, adrs2% Dim m As Double, s As Double Dim LRA%: LRA = Cells(Rows.Count, 1).End(3).Row Dim St_year%, End_year Dim cont%: cont = 1 Range("d2:Q" & LRA).ClearContents For i = 2 To LRA St_year = Year(Range("a" & i)) End_year = Year(Range("B" & i)) If Range("a" & i) > Range("B" & i) Then MsgBox "you an Error on range: " _ & Range("a" & i).Resize(, 2).Address & Chr(10) & _ "the start date < then end One" & Chr(10) & _ "please check your data and Rerun the Macro": Exit Sub If St_year = End_year Then ReDim arr_val(1 To 1) arr_val(1) = St_year Else For ind = 1 To End_year - St_year + 1 ReDim Preserve arr_val(1 To ind) arr_val(ind) = St_year + cont - 1 cont = cont + 1 Next End If '========================================= If UBound(arr_val) = 1 Then adrs1 = Rows(1).Find(arr_val).Column Select Case Day(Range("a" & i)) Case Is < 15: def1 = -0.5 Case Else: def1 = 0.5 End Select Select Case Day(Range("b" & i)) Case Is < 15: def2 = 0 Case Else: def2 = 1 End Select m = Month(Range("b" & i)) - Month(Range("a" & i)) + def1 + def2 - 1 Cells(i, adrs1) = Abs(m) * Range("c" & i) End If '========================================= '++++++++++++++++++++++++++++++++++++++++++++++ If UBound(arr_val) <> 1 Then adrs1 = Rows(1).Find(arr_val(1), lookat:=1).Column adrs2 = Rows(1).Find(arr_val(UBound(arr_val)), lookat:=1).Column Select Case Day(Range("a" & i)) Case Is < 15: m = 13 - Month(Range("a" & i)) Case Else: m = 13 - Month(Range("a" & i)) - 0.5 End Select Cells(i, adrs1) = m * Range("c" & i) '============================ Select Case Day(Range("b" & i)) Case Is < 15: m = Month(Range("b" & i)) - 0.5 Case Else: m = Month(Range("b" & i)) End Select Cells(i, adrs2) = m * Range("c" & i) For t = LBound(arr_val) + 1 To UBound(arr_val) - 1 adrs1 = Rows(1).Find(arr_val(t)).Column Cells(i, adrs1) = 12 * Range("c" & i) Next End If Erase arr_val: cont = 1 Next Columns("d:Q").AutoFit End Sub الملف مرفق Mounth_Price_new.xlsm

بعد اذن اخي بن علية ربما ينفع هذا الكود Option Explicit Sub cut_my_number_Please() Dim reg As Object Dim MY_match Dim Matches Dim i%, lr%: lr = Cells(Rows.Count, 1).End(3).Row Dim k%: k = 3 Dim c%: c = 1 Range("c1").CurrentRegion.ClearContents Set reg = CreateObject("VBscript.RegExp") With reg .Pattern = "1122" .Global = True End With For i = 1 To lr If reg.test(Range("a" & i)) Then Set Matches = reg.Execute(Range("a" & i)) For Each MY_match In Matches Cells(c, k) = MY_match k = k + 1 Next End If k = 3: c = c + 1 Next i End Sub الملف مرفق My_regex.xlsm

ربما هذا الكود اسرع قليلاُ وأقصر في نفس الوقت (يمكنك استعماله) Option Explicit Sub Edit_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("b8:l8"), Range("c9:l9")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("d6")) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("d6")).Row With Me.Range("b8") .Resize(, 11).Value = Cells(r, 2).Resize(, 11).Value .Offset(1, 1) = Cells(r, 13) End With End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub ADD_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("d2")) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Find_rg.Row With Me.Range("b4") Cells(r, 2).Resize(, 11).Value = .Resize(, 11).Value Cells(r, 13) = .Offset(1, 1) End With End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub Ta3dil() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("B4:L4"), Range("C5:L5")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("D2")) If Find_rg Is Nothing Then MsgBox "This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("D2")).Row With Me.Range("b4") .Resize(, 11).Value = Cells(r, 2).Resize(, 11).Value .Offset(1, 1) = Cells(r, 13) End With End Sub

هذه الصورة من اعدادات الاكسل في جهازك (تقول ان هذا الملف فيه معلومات شخصية ويسألك الحفظ ) اضغط موافق في هذا العنوان شرح لهذه الرسالة وكيفية ازالتها اذا اردت https://feasibility.pro/careful-excel-warning/ اذا كان الجواب يفضي بالغرض المطلوب اضغط على افضل اجابة لغلقه

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

لا حاجة للمعادلات في هذا املف الـــ Vba يقوم بكل ما يناسب الملف مرفق مع الشرح الكودات اللازمة Option Explicit Sub Edit_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("b8:l8"), Range("c9:l9")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("d6")) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("d6")).Row With Me.Range("b8") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(1, 1) = Cells(r, 13) End With End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub ADD_data() Dim Source_rg As Range Dim Find_rg As Range Dim r# Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("d2")) If Find_rg Is Nothing Then MsgBox "'This Number Does't Exists" Exit Sub End If r = Find_rg.Row With Me.Range("b4") Cells(r, 2) = .Value: Cells(r, 3) = .Offset(, 1): Cells(r, 4) = .Offset(, 2) Cells(r, 5) = .Offset(, 3): Cells(r, 6) = .Offset(, 4): Cells(r, 7) = .Offset(, 5) Cells(r, 8) = .Offset(, 6): Cells(r, 9) = .Offset(, 7): Cells(r, 10) = .Offset(, 8) Cells(r, 11) = .Offset(, 9): Cells(r, 12) = .Offset(, 10): Cells(r, 13) = .Offset(1, 1) End With End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub Ta3dil() Dim Source_rg As Range Dim Find_rg As Range Dim r# Union(Range("B4:L4"), Range("C5:L5")).ClearContents Dim lra#: lra = Me.Cells(Rows.Count, 1).End(3).Row Set Source_rg = Me.Range("a12:M" & lra) Set Find_rg = Source_rg.Find(Me.Range("D2")) If Find_rg Is Nothing Then MsgBox "This Number Does't Exists" Exit Sub End If r = Source_rg.Find(Me.Range("D2")).Row With Me.Range("b4") .Value = Cells(r, 2): .Offset(, 1) = Cells(r, 3): .Offset(, 2) = Cells(r, 4) .Offset(, 3) = Cells(r, 5): .Offset(, 4) = Cells(r, 6): .Offset(, 5) = Cells(r, 7) .Offset(, 6) = Cells(r, 8): .Offset(, 7) = Cells(r, 9): .Offset(, 8) = Cells(r, 10) .Offset(, 9) = Cells(r, 11): .Offset(, 10) = Cells(r, 12) .Offset(1, 1) = Cells(r, 13) End With End Sub T-2019_Salim.xlsm