الترحيل على حسب الوظيفة مع ادراج صفوف

[فوزى فوزى]

برجاء عمل كود يرحل البيانات الموجودة فى شيت البيانات الى شيت الطباعة على حسب الوظيفة الموجوده فى العمود E  وعند الترحيل الى شيت الطباعة يدرج صفوف اخرى لترحيل البيانات وجزاكم الله خيرا على مجهودكم المتواصل

الترحيل على حسب الوظيفة.xlsm

[lionheart]

Sub Test()
    Dim x, e, ws As Worksheet, sh As Worksheet, r As Range, m As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        With sh.Range("A4:N" & Rows.Count)
            .ClearContents: .Cells.UnMerge: .Borders.Value = 0
        End With
        With ws.[A5].CurrentRegion
            Set r = .Offset(, .Columns.Count + 2).Range("A1:A2")
            x = .Parent.Evaluate("TRANSPOSE(UNIQUE(" & .Columns(5).Offset(1).Address & "))")
            For Each e In x
                If e <> "" Then
                    r(2).Formula = "=E6=""" & e & """"
                    m = sh.Cells(Rows.Count, 1).End(xlUp)(3).Row
                    m = IIf(m <= 5, 4, m)
                    With sh.Range("A" & m)
                        .Value = e
                        .Resize(1, 14).Merge
                        .HorizontalAlignment = xlCenter
                    End With
                    .AdvancedFilter 2, r, sh.Range("A" & m + 1)
                End If
            Next e
            r.ClearContents
        End With
    Application.ScreenUpdating = True
End Sub

 

[أ / محمد صالح]

إن شاء اللّه يفيدك هذا الكود

Sub mas()
Application.ScreenUpdating = 0
Dim lr1        As Long, lr2 As Long, r As Long, c As Long, n As Long
lr1 = Sheet1.Cells(Rows.Count, 1).End(3).Row
lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row
Sheet2.Rows("4:" & IIf(lr2 < 4, 4, lr2)).Delete Shift:=xlUp
For r = 6 To lr1
    c = 0
    Sheet1.Select
    lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row
    If Evaluate("=COUNTIF($E$6:E" & r & ",E" & r & ")") = 1 Then
        Sheet1.Range("A5:N5").Copy
        Sheet2.Select
        Sheet2.Range("A" & lr2 + 2).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Sheet2.Range("f" & lr2 + 1) = Sheet1.Range("e" & r)
        Sheet2.Range("a" & lr2 + 2) = c + 1
        Sheet2.Range("b" & lr2 + 2 & ":N" & lr2 + 2).Value = Sheet1.Range("b" & r & ":N" & r).Value
        c = c + 1
        For n = r + 1 To lr1
            If Sheet1.Range("e" & n) = Sheet1.Range("e" & r) Then
                lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row
                Sheet2.Range("A" & lr2 & ":N" & lr2).Copy
                Range("A" & lr2 + 1).PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
                Sheet2.Range("a" & lr2 + 1) = c + 1
                Sheet2.Range("b" & lr2 + 1 & ":N" & lr2 + 1).Value = Sheet1.Range("b" & n & ":N" & n).Value
                c = c + 1: Sheet2.Range("A4").Select
            End If
        Next n
    End If
Next r
Sheet2.Select
Application.ScreenUpdating = 1
MsgBox "Done by mr-mas.com"
End Sub

وهذا ملفك بعد التعديل

بالتوفيق 

 

الترحيل على حسب الوظيفة.xlsm

[فوزى فوزى]

ما شاء الله تتسابقون فى الخير ربنا يحفظكم ويرزقكم ويسدد خطاكم كود الاستاذ محمد شغال معى تمام

اما كود الاستاذ lionheart عند التجربة ظهر هذا الخطا

[lionheart]

Maybe the problem is with the UNIQUE function as it works on newer versions of excel only

[lionheart]

Try this version for earlier versions of office

Sub Test()
    Dim a, x, e, ws As Worksheet, sh As Worksheet, r As Range, m As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        With sh.Range("A4:N" & Rows.Count)
            .ClearContents: .Cells.UnMerge: .Borders.Value = 0
        End With
        With ws.[A5].CurrentRegion
            Set r = .Offset(, .Columns.Count + 2).Range("A1:A2")
            a = Application.Transpose(.Columns(5).Offset(1).Value)
            With Application
                x = .Index(a, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & UBound(.Match(a, a, 0)) & ")")), .Match(a, a, 0), 0), "|"), "|", False))
            End With
            For Each e In x
                If e <> "" Then
                    r(2).Formula = "=E6=""" & e & """"
                    m = sh.Cells(Rows.Count, 1).End(xlUp)(3).Row
                    m = IIf(m <= 5, 4, m)
                    With sh.Range("A" & m)
                        .Value = e
                        .Resize(1, 14).Merge
                        .HorizontalAlignment = xlCenter
                    End With
                    .AdvancedFilter 2, r, sh.Range("A" & m + 1)
                End If
            Next e
            r.ClearContents
        End With
    Application.ScreenUpdating = True
End Sub

 

[فوزى فوزى]

شكرا للاستاذ محمد وللاستاذ قلب الاسد لجهودهم المستمرة ونشاطهم الواضح والداعم لنا ورزقهم الله الفردوس الاعلى

[أ / محمد صالح]

جميعا بإذن الله 

[ميدو63]

الكود الاول والثانى روعة

شكرا لكم