فوزى فوزى قام بنشر سبتمبر 25, 2021 قام بنشر سبتمبر 25, 2021 برجاء عمل كود يرحل البيانات الموجودة فى شيت البيانات الى شيت الطباعة على حسب الوظيفة الموجوده فى العمود E وعند الترحيل الى شيت الطباعة يدرج صفوف اخرى لترحيل البيانات وجزاكم الله خيرا على مجهودكم المتواصل الترحيل على حسب الوظيفة.xlsm
lionheart قام بنشر سبتمبر 25, 2021 قام بنشر سبتمبر 25, 2021 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 1
أفضل إجابة أ / محمد صالح قام بنشر سبتمبر 25, 2021 أفضل إجابة قام بنشر سبتمبر 25, 2021 إن شاء اللّه يفيدك هذا الكود 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 1
فوزى فوزى قام بنشر سبتمبر 25, 2021 الكاتب قام بنشر سبتمبر 25, 2021 ما شاء الله تتسابقون فى الخير ربنا يحفظكم ويرزقكم ويسدد خطاكم كود الاستاذ محمد شغال معى تمام اما كود الاستاذ lionheart عند التجربة ظهر هذا الخطا
lionheart قام بنشر سبتمبر 25, 2021 قام بنشر سبتمبر 25, 2021 Maybe the problem is with the UNIQUE function as it works on newer versions of excel only
lionheart قام بنشر سبتمبر 25, 2021 قام بنشر سبتمبر 25, 2021 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 3
فوزى فوزى قام بنشر سبتمبر 25, 2021 الكاتب قام بنشر سبتمبر 25, 2021 شكرا للاستاذ محمد وللاستاذ قلب الاسد لجهودهم المستمرة ونشاطهم الواضح والداعم لنا ورزقهم الله الفردوس الاعلى 2
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.