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

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 سيعطي رسالة خطأ

بارك الله

إن شاء الله التقرير.xlsm

1- لان الأرقام غير موجودة بالاساس

بارك الله

ربما البحث بشرط او اكثر.xlsx

بفرض أن الملفين في نفس المسار(في نفس الفولدر) 2.xlsm

وعليكم السلام تفضل أخي الكريم ولكن أرجو الانتباه إلى أرقام الصفحات يجب أن تمون دائما بالشكل (-12-) عدلت بعضها مثل (-12) أرجو تعديل الباقي أي استفسار انا جاهز kutub202022 (1).xlsm

فقط استبدل بالكود القديم Sub Test() Dim a, b, x Dim i, ii Dim nmsht, dt, bk Dim p As Long Dim ar As Long Dim tmp, class, br, mat Const c As Integer = 25 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("book") For ii = 1 To UBound(a) Step c x = Split(.[E:E].Find("-" & p & "-", , , 1).Address, "$")(2) .Cells(x - 6 - c, 4) = .Cells(x - 6 - c, 4) & " " & class .Cells(x - 6 - c, 9) = .Cells(x - 6 - c, 9) & " " & br .Cells(x - 6 - c, 15) = mat zzZ = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "") For i = 1 To 10 .Cells(x - 1 - c, 2 + m) = Z(i, 2) mm = mm + 4 Next ar = ar + c p = p + 2 Next End With Next End Sub

عادة الخلايا المدموجة والأكواد لا يتفقان لذلك.....!!

في شيت يومي يمكن نسخ أي جدول واقحامه بين جدولين باستخدام "Insert Coped Cells" في الكود المرفق يمكنك إضافة أو إقحام صفوف و عليك أن تضيف الصفوف كما ذكرت سابقاً بنفس ترتيب الجدول عسى ولعل يرضيك هذا الحل ايجاد كود للتوزيع3.xlsm

😀

عليكم السلام طبعا الإضافة تكون بنفس الترتيب (I hope) حبذا لو مثال أو أمثلة في الشيتين طبعاً شكراً

عليكم السلام والرحمة عسى يكون المطلوب مع ملا حظة أن الدرس السادس كما لا حظت فارغ دائما وإلا الكود لن يعمل إذا ولا بد اعلمني للتعديل ايجاد كود للتوزيع.xlsm

clsTB = Sub clsTB() For i = 1 To 25 UserForm1.Controls("TextBox" & i).Value = "" Next End Sub بدل Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox7.Value = "" Me.TextBox8.Value = "" Me.TextBox9.Value = "" Me.TextBox10.Value = "" Me.TextBox11.Value = "" Me.TextBox12.Value = "" Me.TextBox13.Value = "" Me.TextBox14.Value = "" Me.TextBox15.Value = "" Me.TextBox16.Value = "" Me.TextBox17.Value = "" Me.TextBox18.Value = "" Me.TextBox19.Value = "" Me.TextBox20.Value = "" Me.TextBox21.Value = "" Me.TextBox22.Value = "" Me.TextBox23.Value = "" Me.TextBox24.Value = "" Me.TextBox25.Value = "" مثلا doc.docx

بالاذن منكم أعتقد هكذا مع بض اللمسات🙏 userform.xlsm

الحمد لله وكل الشكر

أخي العزيز ممكن تستبدل بهذا الكود عسى ولعل Sub test() Dim ws As Worksheet: Set ws = Sheets("توزيع المبالغ") Dim sh As Worksheet: Set sh = Sheets("تجميع المبالغ") Dim a, b, c, m, d Dim x# Dim i&, ii& a = ws.Cells(6, 7).CurrentRegion b = sh.Cells(6, 1).CurrentRegion.Offset(2).Columns(1) ReDim c(1 To UBound(b) - 2, 1 To 2) m = ws.Range("E1") For i = 2 To UBound(a) For ii = 6 To UBound(a, 2) If (a(i, ii)) = "" Then Exit For x = Application.Match(a(i, ii), b, 0) c(x, 1) = IIf(c(x, 1) = "", a(i, 2), c(x, 1) & " + " & a(i, 2)) If a(i, 4) <= m Then c(x, 2) = c(x, 2) + a(i, 4) Else c(x, 2) = c(x, 2) + m: a(i, 4) = a(i, 4) - m End If Next Next d = sh.Range(sh.Cells(5, 4), sh.Cells(5, 4).End(xlToRight)).Value On Error Resume Next For i = 1 To UBound(d, 2): d(1, i) = 1 * Split(d(1, i), "/")(0): Next d = Application.Transpose(d) x = Application.Match(1 * Split(ws.Range("E7"), "/")(0), d, 0) With sh .Cells(6, 2).Resize(UBound(c)) = c .Cells(6, x + 3).Resize(UBound(c)) = Application.Index(c, 0, 2) End With End Sub

غريب فعلا غريب جربته اكثر من مرة عندي ويعمل بشكل جيد ربما نسخ الاكسل عندك!! انا أعمل على نسخة 2019 الجمعية الشهرية (2) (3).xlsm

تفضل الجمعية الشهرية (2) (3).xlsm

المشكلة لا أدري اين إدخال الشهر (في أي خلية)!!!! أنا افترضت التغيير في الخلية E1!!!!?

عليكم السلام اذا كانت ِA1=G1 لم أجدها في B1,B10,B60 أم أني لم أفهم المطلوب!!!

عليكم السلام ممكن؟؟!!! Sub test() Dim ws As Worksheet: Set ws = Sheets("توزيع المبالغ") Dim sh As Worksheet: Set sh = Sheets("تجميع المبالغ") Dim a, b, c, m, d Dim i&, ii&, x& a = ws.Cells(6, 7).CurrentRegion b = sh.Cells(6, 1).CurrentRegion.Offset(2).Columns(1) ReDim c(1 To UBound(b) - 2, 1 To 2) m = ws.Range("E1") For i = 2 To UBound(a) For ii = 6 To UBound(a, 2) If (a(i, ii)) = "" Then Exit For x = Application.Match(a(i, ii), b, 0) c(x, 1) = IIf(c(x, 1) = "", a(i, 2), c(x, 1) & " + " & a(i, 2)) If a(i, 4) <= m Then c(x, 2) = c(x, 2) + a(i, 4) Else c(x, 2) = c(x, 2) + m: a(i, 4) = a(i, 4) - m End If Next Next d = sh.Range(sh.Cells(5, 1), sh.Cells(5, 1).End(xlToRight)).Value On Error Resume Next For i = 1 To UBound(d, 2): d(1, i) = Split(d(1, i), "/")(0): Next d = Application.Transpose(d) x = Application.Match(Split(ws.Range("E7"), "/")(0), d, 0) With sh .Cells(6, 2).Resize(UBound(c)) = c .Cells(6, x).Resize(UBound(c)) = Application.Index(c, 0, 2) End With End Sub الجمعية الشهرية (2) (3).xlsm

ما معنى هذه الكلمة UBound Ubouind(a) من أبعاد المصفوفة a مثال مصفوفة 4×3 Ubound(a,1) =4 Ubound(a,2) =3

هكذا؟ عادل ماذا عنه الجمعية الشهرية (2).xlsm