محمد عدنان قام بنشر مارس 10 مشاركة قام بنشر مارس 10 السلام عليكم و رحمة الله و بركاته ارجو المساعدة في عمل ماكرو تكويد للمواد في الملف المرفق من الصفحة 1 الى الصفحة 2 علما بان معادلة التكويد هي (يكون برمز JAF+ رقم السجل + رقم الصفحة + تسلسل رصيد المادة ) من الصفحة 1 و يرحل الى الصفحة 2 يوجد الناتج النهائي في الصفحة 2 كمثال للناتج النهائي ل 3 مواد بشكل يدوي في الملف المرفق يوجد شرح اكثر في الملف و جزاكم الله كل خير code 2024.xlsx رابط هذا التعليق شارك More sharing options...
lionheart قام بنشر مارس 10 مشاركة قام بنشر مارس 10 Delete the rows in sheet2 from row 5 to row 25 then try this code Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5 Application.ScreenUpdating = False For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i End If Next r Application.ScreenUpdating = True End Sub I didn't merge the cells as it is not practical 1 رابط هذا التعليق شارك More sharing options...
محمد عدنان قام بنشر مارس 11 الكاتب مشاركة قام بنشر مارس 11 السلام عليكم بارك الله بك استاذ @lionheart هل هناك طريقة عملية بدل دمج الخلايا المتشابهة ؟ هل بالامكان فصل بين كل مادة بسطر فارغ ملون كحل لعدم دمج الخلايا بارك الله بعلمك الكود يعمل بما هو مطلوب لكن كثرة المواد تصبح تشتت المستخدم رابط هذا التعليق شارك More sharing options...
lionheart قام بنشر مارس 11 مشاركة قام بنشر مارس 11 Here's a modification to let empty row between results but I won't merge cells Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5 Application.ScreenUpdating = False For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 End If Next r Application.ScreenUpdating = True End Sub 1 رابط هذا التعليق شارك More sharing options...
أفضل إجابة lionheart قام بنشر مارس 11 أفضل إجابة مشاركة قام بنشر مارس 11 Here's a version that merges cells although I see not practical and not useful later Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, n As Long, i As Long, c As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5: n = m Application.ScreenUpdating = False Application.DisplayAlerts = False With sh.Rows("5:" & Rows.Count) .ClearContents: .Borders.Value = 0: .UnMerge: .RowHeight = 20.25 End With For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i For c = 1 To 3 With sh.Range(sh.Cells(n, c), sh.Cells(m - 1, c)) .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Next c If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 n = m End If Next r sh.Range("A5:F" & m - 1).Borders.Value = 1 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub 2 رابط هذا التعليق شارك More sharing options...
محمد عدنان قام بنشر مارس 11 الكاتب مشاركة قام بنشر مارس 11 بارك الله فيك و جزاك الله كل خير استاذنا الكبير @lionheart شكرا لك الكود يعمل بما هو مطلوب 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان