تكويد المواد

[محمد عدنان]

السلام عليكم و رحمة الله و بركاته 

ارجو المساعدة في عمل ماكرو تكويد  للمواد في الملف المرفق  من الصفحة 1 الى الصفحة 2

علما بان معادلة التكويد هي (يكون برمز JAF+ رقم السجل + رقم الصفحة + تسلسل  رصيد المادة ) من الصفحة 1

و يرحل الى الصفحة 2 

يوجد الناتج النهائي في الصفحة 2 كمثال للناتج النهائي ل 3 مواد  بشكل يدوي  في الملف المرفق

يوجد شرح اكثر في الملف 

و جزاكم الله كل خير 

code 2024.xlsx

[lionheart]

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

[محمد عدنان]

السلام عليكم 

بارك الله بك استاذ @lionheart 

هل هناك طريقة عملية بدل دمج الخلايا المتشابهة ؟

هل بالامكان فصل بين كل مادة بسطر فارغ ملون كحل لعدم دمج الخلايا 

بارك الله بعلمك الكود يعمل بما هو مطلوب لكن كثرة المواد تصبح تشتت المستخدم

[lionheart]

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

 

[lionheart]

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

 

[محمد عدنان]

بارك الله فيك و جزاك الله كل خير استاذنا الكبير @lionheart

شكرا لك  الكود يعمل بما هو مطلوب