فوزى فوزى قام بنشر فبراير 9, 2023 مشاركة قام بنشر فبراير 9, 2023 السلام عليكم ورحمة الله وبركاته عباقرة منتدى اوفيسنا الأعزاء الشيت به كود للمبدع الأستاذ محى الدين أبو البشر وهو كود يقوم بعمله على اكمل وجه ولكن ورد الينا تعليمات جديدة ان يكون الادخال معتمد على رقم اللجنة وعدد الأعضاء داخل كل لجنة بمعنى كان الادخال عدد الترحيل كان معتمد على الخلية F2 وكان الكود يرحل ممتاز ولا يعيبه شئ ولكن الان سيتم ادخال البيانات عن طريق عمود رقم اللجنة وعمود العدد المطلوب ترحيله بمعنى ان اكتب لجنة رقم 1 والعدد المطلوب ترحيله 23 يرحل الى الكشف الاول 23 اسم من رقم اللجنة 1 وكتبت مرة رقم اللجنة 1 العدد المطلوب ترحيله 20 اذا يرحل فى كشف الثانى 20 اسم من لجنة رقم 1 وهكذا الترحيل يكون من التقرير الى شيت كشف الطباعة وجعلكم الله عونا لنا وللامثالنا ترحيل الاسماء (2).xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة محي الدين ابو البشر قام بنشر فبراير 11, 2023 أفضل إجابة مشاركة قام بنشر فبراير 11, 2023 تفضل أخي الكريم ربما؟ 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 3 رابط هذا التعليق شارك More sharing options...
فوزى فوزى قام بنشر فبراير 11, 2023 الكاتب مشاركة قام بنشر فبراير 11, 2023 بارك الله فى جهدك سيدى الكريم الاستاذ محى الدين عمل فى قمة الروعة والجمال وكانه حلم وتحقق على يديكم الف الف مليون شكرا ربنا يجزيكم الجنة رابط هذا التعليق شارك More sharing options...
محي الدين ابو البشر قام بنشر فبراير 12, 2023 مشاركة قام بنشر فبراير 12, 2023 بارك الله رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان