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

بارك الله

تفضل Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim a Dim i&, r& Dim ws As Worksheet, sh As Worksheet Set ws = Sheet1: Set sh = Sheet2 With ws a = .Range(.Range("A10:G10"), .Range("A10:G10").End(xlDown)) End With If Target.Address = "$F$8" Then r = Sheet1.Cells.Find(Target, , , 1).Column With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) = sh.Cells(8, 5) Then If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, r) Else .Item(a(i, 1)) = .Item(a(i, 1)) & "|" & a(i, r) End If: End If Next a = Split(.items()(0), "|") With sh.Cells(10, 6) .Resize(Rows.Count - .Row + 1).ClearContents .Resize(UBound(a) + 1) = Application.Transpose(a) End End With End With End If End Sub رزان2.xlsm

تفضل أخي الكريم ربما؟ Sub test2() Dim ws As Worksheet: Set ws = Sheets("التقرير") Dim sh As Worksheet: Set sh = Sheets("كشف الطباعة") Dim a, b, w Dim i&, c&, ii&, kk& Dim r As Range Dim f As String a = ws.Range(ws.Cells(6, 1), ws.Cells(6, 4).End(xlDown)) b = ws.Range(ws.Cells(6, 6), ws.Cells(6, 7).End(xlDown)) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 4)) Then .Add a(i, 4), Array(a(i, 1), a(i, 2), a(i, 3)) Else w = Application.Transpose(.Item(a(i, 4))) ReDim Preserve w(1 To UBound(w), 1 To UBound(w, 2) + 1) w = Application.Transpose(w) For ii = 1 To 3 w(UBound(w), ii) = a(i, ii) Next .Item(a(i, 4)) = w End If Next Set r = sh.Columns("a").Find("م", , , 1) If Not r Is Nothing Then f = r.Address: i = 1 Do w = .Item(.Keys()(kk)) 1 [r].Offset(1).Resize(25, 3).ClearContents [r].Offset(1).Resize(b(i, 2), 3) = Application.IfError(Application.Index(w, _ Evaluate("Row(" & 1 + c & ":" & c + b(i, 2) & ")"), [{1, 2,3}]), "") If i = UBound(b) Then Exit Sub If b(i, 1) = b(i + 1, 1) Then Set r = sh.Columns("a").FindNext(r) c = c + b(i, 2): i = i + 1 GoTo 1 Else: GoTo 2 End If 2 kk = kk + 1: i = i + 1: c = 0 Set r = sh.Columns("a").FindNext(r) Loop Until r.Address = f End If End With End Sub ترحيل أسماء.xlsm

بارك الله

عليكم السلام ربما Private Sub CommandButton3_Click() Dim c&, i& For i = 0 To ListBox1.ListCount - 1 With Sheets("ورقة1") .Range("g6").Offset(c).Value = ListBox1.List(i, 0) .Range("h6").Offset(c).Value = ListBox1.List(i, 1) .Range("i6").Offset(c).Value = ListBox1.List(i, 2) c = c + 1 End With Next i End Sub

🙏

هي (عدد أعمدة) وليس range او cells!!!!!

وعليكم السلام والرحمة كود: Sub test() Dim a Dim x&, i&, c& Dim r As Range Dim firstaddress As String With Sheets("التقرير") a = .Range(.Cells(6, 1), .Cells(6, 3).End(xlDown)) x = .Cells(2, 6) End With With Sheets("كشف الطباعة") Set r = .Columns("a").Find("م", , , 1) If Not r Is Nothing Then firstaddress = r.Address Do [r].Offset(1).Resize(x, UBound(a, 2)) = Application.IfError(Application.Index(a, _ Evaluate("Row(" & c + 1 & ":" & x + c & ")"), [{1, 2,3}]), "") Set r = .Columns("a").FindNext(r) c = c + x Loop Until r.Address = firstaddress End If End With End Sub ترحيل الاسماء.xlsm

عليكم السلام ورحمة الله وبركاته تفضل أخي الكريم Sub test() With Sheets("يومية الحضور والإنصراف").Range("B4:C" & Sheets("يومية الحضور والإنصراف").Cells(Rows.Count, 1).End(xlUp).Row) .Formula = "=IFERROR(VLOOKUP($A:$A,Table9,COLUMN(),0),"""")" .Value = .Value End With With Sheets("رصيد الأجازات").Range("B3:D" & Sheets("رصيد الأجازات").Cells(Rows.Count, 2).End(xlUp).Row) .Formula = "=IFERROR(VLOOKUP($A:$A,Table9,COLUMN(),0),"""")" .Offset(, 3).Resize(, 1).Formula = "=IFERROR(IF(DATEDIF([@[تاريخ التعيين]],$D$1,""D"")/30>3.1,""يستحق"",""""),"""")" .Offset(, 5).Resize(, 1).Formula = "=IF([@[معادلة الرصيد]]=""يستحق"",$O$1+[@[معالجة الرصيد]],0)" .Offset(, 6).Resize(, 1).Formula = "=[@[الرصيد المرحل]]+[@[رصيد 2023]]" .Offset(, 7).Resize(, 1).Formula = "=(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A3,'يومية الحضور والإنصراف'!$H:$H,""أجازة"")+(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A3,'يومية الحضور والإنصراف'!$H:$H,""أجازة مجمعة"")))" .Offset(, 8).Resize(, 1).Formula = "=(COUNTIFS('يومية الحضور والإنصراف'!$A:$A,$A4,'يومية الحضور والإنصراف'!$H:$H,""أجازة عارضة""))" .Offset(, 9).Resize(, 1).Formula = "=IF(E3=""يستحق"",$N$1-[@[ عارضة]],0)" .Offset(, 10).Resize(, 1).Formula = "=(([@[إجمالي الرصيد المستحق]]-([@[ سنوي]]+[@[ عارضة]]+[@[تسوية نقدي]])))-[@[باقي رصيد العارضة]]" .Offset(, 11).Resize(, 1).Formula = "=([@[باقي رصيد السنوي ]]+[@[باقي رصيد العارضة]])" With .Resize(, 12) .Value = .Value End With End With End Sub

بالاذن Book1 (2).xlsx

E2=IF(OR(A2<>"",B2<>""),IF(AND(A2<>"",B2=""),"قبض","صرف"),"") ربما ادرج نوع العملية تلقائي.xlsx

يدوياً؟ قم باختيار الجدول ( ليس من الخلايا وإنما كامل الأسطر) بمعني اضغط على الرقم 1 بجانب الخلية A1 نزولا حتى آخر الجدول) ثم CTR+ Copy ثم right click على أول خلية تريد النسخ فيها وقم باختيار (Insert Copied cells) ويمكن عمل ذلك بماكرو إذا أحببت

السلام عليكم بالأذن من الجميع ممكن تجربة؟ برمجة حساب راتب (1).xlsm

جرب هذا Sub Oval1_Click() Dim xDir As String Dim xFile As String Dim xRow As Long With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Title = "Please select the files" .Filters.Clear .Filters.Add "All supported files", "*.*" If .Show = -1 Then xDir = .SelectedItems(1) xFile = Dir(xDir & Application.PathSeparator & "*.docx") Do Until xFile = "" xRow = 0 On Error Resume Next xRow = Application.Match(xFile, Range("A:A"), 0) If xRow > 0 Then Name xDir & Application.PathSeparator & xFile As _ xDir & Application.PathSeparator & Cells(xRow, "B").Value End If xFile = Dir Loop End If End With End Sub

الحمد لله ولك تحياتي وكل عام وأنتم بخير

عليكم السلام وارحمة وكل عام وأنتم بألف خير أخي الكريم في كود الترحيل .Cells(x + 1, 15) = mat وفي كود المسح myArea(28, 15) = "" ولك تحياتي

بارك الله

بسيطة Sub protect_sh() Dim i& Dim p As String p = InputBox("ÃÏÎá ßáãÉ ÇáÓÑ") For i = 1 To Sheets.Count Sheets(i).Protect p Next End Sub Sub unprotectsh() Dim i& Dim p As String p = InputBox("ÃÏÎá ßáãÉ ÇáÓÑ") For i = 1 To Sheets.Count Sheets(i).Unprotect p Next End Sub

عليكم السلام تقضل أخي الكريم عسى المطلوب طلب ترحيل بالاسم والتاريخ.xlsm

الحمد لله ولك مثل ما دعوت وأكثر

أه الآن دارت الفكرة آسف لم استوعب الفكرة عذراً منك جرب هذا واعتذر مرة أخرى عن سوء الفهم kutub20-23 -222.xlsm

ممكن Sub protect_sh() Dim i For i = 1 To Sheets.Count Sheets(i).protect "ggg" '<<< كلمة السر Next End Sub Sub unprotectsh() Dim i For i = 1 To Sheets.Count Sheets(i).unprotect "ggg" '<<< كلمة السر Next End Sub

ربما Classeur1.xlsm

ولا يهمك وشكراً لك

Option Explicit Sub Test() Dim a, b, x, z Dim i&, ii&, iii&, mm& Dim nmsht, dt, bk Dim p As Long Dim ar As Long Dim tmp, class, br, mat Const c As Integer = 10 Set nmsht = Sheets("name") Set dt = Sheets("data") Set bk = Sheets("Book") b = dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown)).Resize(, 3) p = 4: For i = 1 To UBound(b) tmp = Split(b(i, 1)) class = IIf(UBound(tmp) < 3, tmp(1), (tmp(0) & " " & tmp(1)) & " " & tmp(2)) br = tmp(UBound(tmp)): mat = b(i, 3) With nmsht.Range("b2:AX400") x = .Find(b(i, 1), , , 1).Address a = .Range(x).Offset(3, -1).Resize(.Range(nmsht.Range(x).Offset(3), nmsht.Range(x).Offset(3).End(xlDown)).Count, 2).Offset(-2, -1) End With ar = 1 With Sheets("book2") For ii = 1 To UBound(a) Step c x = Split(.[E:E].Find("-" & p & "-", , , 1).Address, "$")(2) .Cells(x - 6 - 39, 4) = Split(.Cells(x - 6 - 39, 4))(0) & " " & class .Cells(x - 6 - 39, 9) = Split(.Cells(x - 6 - 39, 9))(0) & " " & br z = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c - 1 & "))"), Array(1, 2)), "") For iii = 1 To UBound(z) .Cells(x - 1 - 39 + mm, 1) = z(iii, 1) .Cells(x - 1 - 39 + mm, 2) = z(iii, 2) mm = mm + 4 Next ar = ar + c p = p + 2 mm = 0 Next End With Next End Sub مرة أخرى (أرقام الصفحات يجب أن تمون دائما بالشكل (-12-) عدلت بعضها مثل (-12) أرجو تعديل الباقي) إذا كان رقم الصفحة 128- أو -128 سيعطي رسالة خطأ