اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

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

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

قام بنشر
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

 

  • Like 1
  • أفضل إجابة
قام بنشر

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

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

  • Like 1
قام بنشر

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

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

121.PNG

قام بنشر

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

 

  • Like 3
قام بنشر

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

  • Like 2

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information