محي الدين ابو البشر

نفس الكود معدل حسب اظروف الراهنة Sub Trhile() Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim sh As Worksheet: Set sh = Sheets("تجميع الغياب") Dim lr&, r&, col& lr = ws.Cells(Rows.Count, 2).End(xlUp).Row + 1 On Error Resume Next r = Range(Cells(7, 2), Cells(7, 2).End(xlDown)).Cells.Find(ws.Range("b2").Value, , , 1).Row On Error GoTo 0 lr = IIf(r = 0, lr, r) ws.Cells(lr, 2) = ws.Range("b2").Value ws.Cells(lr, ws.Range("A6:AG6").Cells.Find(Split(ws.[d2].Value, "/")(1), , -4163, 1).Column).Resize(, ws.[F2].Value) = ws.[C2].Value r = sh.Cells.Find(ws.[b2].Value, , , 1).Row col = sh.Cells.Find(ws.[C2].Value).Column sh.Cells(r, col).Value = ws.[d2].Value sh.Cells(r, col).Offset(, 1) = ws.[e2].Value sh.Cells(r, col).Offset(, 2) = ws.[F2].Value End Sub

ربما Sub test2() Dim a Dim LR& a = Sheets("sheet1").Cells(13, 2).CurrentRegion With Sheets("sheet2").Cells(10, 4) LR = Cells(Rows.Count, 4).End(xlUp).Row .Resize(LR, 3).ClearContents .Offset(, 8).Resize(LR).ClearContents .Offset(, 10).Resize(LR).ClearContents .Offset(, 12).Resize(LR).ClearContents .Resize(UBound(a) - 1, 3) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), Array(2, 3, 4)) .Offset(, 8).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 7) .Offset(, 10).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 10) .Offset(, 12).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 5) End With End Sub

عليكم السلام ملف استدعاء.rar

بارك الله

تفضل أخي الكريم Private Sub TextBox3_Change() TextBox4 = IIf(TextBox1 = "", 1, TextBox1) * IIf(TextBox2 = "", 1, TextBox2) * IIf(TextBox3 = "", 1, TextBox3) End Sub Private Sub TextBox2_Change() TextBox4 = IIf(TextBox1 = "", 1, TextBox1) * IIf(TextBox2 = "", 1, TextBox2) * IIf(TextBox3 = "", 1, TextBox3) End Sub Private Sub TextBox1_Change() TextBox4 = IIf(TextBox1 = "", 1, TextBox1) * IIf(TextBox2 = "", 1, TextBox2) * IIf(TextBox3 = "", 1, TextBox3) End Sub بالنسبة لـ 0.25*0.23*0.26 يضرب تماما ولكن اعتقد انه يجب عند كتابة الرقم تبدأ بـ 0 تم . ثم بقية الرقم

طالما عملية ضرب فالنتيجة ستكون صفر ÷كذا في الرياضيات أو الحساب إلا إذا تريد شيئ آخر يرجى الإيضاح أكثر

ربما؟!!! متابعة.xlsx

جرب هذا Sub test() Dim a Dim i& a = Cells(6, 3).Resize(Cells(Rows.Count, 3).End(xlUp).Row - 5, 10) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 10) Else: .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, 10): End If Next x = Range(Range("M3"), Range("M3").End(xlToRight)) For Each k In .keys Set r = Cells.Find(k, , , 1) r.Offset(3) = .Item(k) Next End With End Sub

وعليكم السلام ربما مخزن 2023.xls

بارك الله

هذا الكود يقوم بتفح ورقة جديدة على حسب المكتوب في AM14 المطلوب ان يقوم بقفل و حماية هذه الورقة الذي يقوم بفتحها لعدم العبث او تخريب البيانات بها Sub CopySheet() Dim strName As String, Sh As Worksheet strName = Trim(Sheet4.Range("am14").Value) For Each Sh In Worksheets If Sh.Name = strName Then Exit Sub Next Sh Sheet4.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = strName ActiveSheet.Protect "password" ' ضع كلمة السر بدل password With Sheets(strName) .Shapes("Button 1").Delete With .Range("b10:am1009") .Value = .Value End With End With Sheets("الشاشة الرئيسية").Select Range("A1").Select End Sub

Private Sub TextBox3_Change() If (TextBox1 <> "" And TextBox2 <> "" And TextBox3 <> "") Then TextBox4 = TextBox1 * TextBox2 * TextBox3 Else TextBox4 = "" End If End Sub Private Sub TextBox2_Change() If (TextBox1 <> "" And TextBox2 <> "" And TextBox3 <> "") Then TextBox4 = TextBox1 * TextBox2 * TextBox3 Else TextBox4 = "" End If End Sub Private Sub TextBox1_Change() If (TextBox1 <> "" And TextBox2 <> "" And TextBox3 <> "") Then TextBox4 = TextBox1 * TextBox2 * TextBox3 Else TextBox4 = "" End If End Sub هكذا؟!

وممكن أيضاً هكذا ضرب.xlsm

ربما BookXX.xlsm

مع ذلك ممكن أيضاَ Private Sub TARHIL_Click() Dim lr&, r&, col& With Sheets("البيانات") lr = .Cells(Rows.Count, 2).End(xlUp).Row + 1 On Error Resume Next r = Cells.Find(ComboBox1.Value, , , 1).Row On Error GoTo 0 lr = IIf(r = 0, lr, r) .Cells(lr, 2) = ComboBox1.Value .Cells(lr, .Range("A6:AG6").Cells.Find(Split(TextBox4.Value, "/")(0), , -4163, 1).Column).Resize(, TextBox6.Value) = ComboBox3.Value End With With Sheets("تجميع الغياب") r = .Cells.Find(ComboBox1.Value, , , 1).Row col = .Cells.Find(ComboBox3.Value).Column With .Cells(r, col) .Value = TextBox4.Value .Offset(, 1) = TextBox5.Value .Offset(, 2) = TextBox6.Value End With End With End Sub

عليكم السلام عسى Private Sub TARHIL_Click() Dim lr&, r&, col& With Sheets("البيانات") lr = .Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(lr, 2) = ComboBox1.Value .Cells(lr, .Range("A6:AG6").Cells.Find(Split(TextBox4.Value, "/")(0), , -4163, 1).Column).Resize(, TextBox6.Value) = ComboBox3.Value End With With Sheets("تجميع الغياب") r = .Cells.Find(ComboBox1.Value, , , 1).Row col = .Cells.Find(ComboBox3.Value).Column With .Cells(r, col) .Value = TextBox4.Value .Offset(, 1) = TextBox5.Value .Offset(, 2) = TextBox6.Value End With End With End Sub Book.xlsm

Set WRng = Intersect(Application.ActiveSheet.Range("B8:B1000"), Target) 'المجال الأول وهو العمود B Set WRng2 = Intersect(Application.ActiveSheet.Range("d8:d1000"), Target) 'المجال الثاني وهو العمود D On Error Resume Next ST1 = 1 ' عدد إزاحة النتيجة الذي سيتم وضع نتيجة فحص العمود B في هذه الحالة سيتم الإزاحة بمقدر 1 اي النتيجة ستكون في العمو د C ST2 = 1 ' عدد إزاحة النتيجة الذي سيتم وضع نتيجة فحص العمود D في هذه الحالة سيتم الإزاحة بمقدر 1 اي النتيجة ستكون في العمو د F

عليكم السلام لا داعي لكود يمكن عمل ذلك من Custom << Format cells << وهناك يمكنك الاستبدال

يمكن اختصار .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6), _ a(i, 7), a(i, 8), a(i, 9), a(i, 10), a(i, 11), a(i, 12), a(i, 13), a(i, 14), a(i, 15), _ a(i, 16), a(i, 17), a(i, 18), a(i, 19), a(i, 20), a(i, 21), a(i, 22), a(i, 23), _ a(i, 24), a(i, 25), a(i, 26), a(i, 27)), Array(a(i, 28), a(i, 29))) إلى .Add a(i, 1), Array(Application.Transpose(Application.Index(a, i, Evaluate("row(1:" & UBound(a, 2) - 2 & ")"))), _ Array(a(i, UBound(a, 2) - 1), a(i, UBound(a, 2)))) Sub test() Dim a, aa, w Dim i& a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Application.Transpose(Application.Index(a, i, Evaluate("row(1:" & UBound(a, 2) - 2 & ")"))), _ Array(a(i, UBound(a, 2) - 1), a(i, UBound(a, 2)))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, UBound(a, 2) - 1) w(1)(1) = w(1)(1) & "|" & a(i, UBound(a, 2)) .Item(a(i, 1)) = w End If Next For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(14, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub

لا تعب هل من الممكن عرض ما توصلت إلية؟ لللإفادة

بارك الله

ربما Sub CopySheet() Dim strName As String, SH As Worksheet strName = Trim(Sheet4.Range("o14").Value) For Each SH In Worksheets If SH.Name = strName Then Exit Sub Next SH Sheet4.Copy after:=Sheets(Sheets.Count) Sheets("sheet1 (2)").Name = strName With Sheets(strName) .Shapes("Button 1").Delete With .Range("A10:Z400") .Value = .Value End With End With Sheets("sheet1").Select Range("A1").Select End Sub

هكذا؟ Sub test() Dim a a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6), a(i, 7), a(i, 8))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, 5) w(1)(1) = w(1)(1) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8) .Item(a(i, 1)) = w End If Next For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(14, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub اذا لم يكن المطلوب أرجو أن ترفق ملف فيه النتائج المتوقعة شكراً

بصراحة لم تصل الفكرة تماما بالإضافة إلى E , F تريد G و H؟ !!! بليز

تفضل أخي الكريم استبدل باكود: Sub test() Dim a a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, 5) w(1)(1) = w(1)(1) & "|" & a(i, 6) .Item(a(i, 1)) = w End If Next itm = .items For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(UBound(a, 2) - 4, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub