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

بارك الله

 تفضل

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

🙏

17 ساعات مضت, فوزى فوزى said:

UBound(a, 2)

هي (عدد أعمدة) وليس 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 سيعطي رسالة خطأ