فوزى فوزى قام بنشر سبتمبر 25, 2021 مشاركة قام بنشر سبتمبر 25, 2021 برجاء عمل كود يرحل البيانات الموجودة فى شيت البيانات الى شيت الطباعة على حسب الوظيفة الموجوده فى العمود E وعند الترحيل الى شيت الطباعة يدرج صفوف اخرى لترحيل البيانات وجزاكم الله خيرا على مجهودكم المتواصل الترحيل على حسب الوظيفة.xlsm رابط هذا التعليق شارك More sharing options...
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 رابط هذا التعليق شارك More sharing options...
أفضل إجابة أ / محمد صالح قام بنشر سبتمبر 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 رابط هذا التعليق شارك More sharing options...
فوزى فوزى قام بنشر سبتمبر 25, 2021 الكاتب مشاركة قام بنشر سبتمبر 25, 2021 ما شاء الله تتسابقون فى الخير ربنا يحفظكم ويرزقكم ويسدد خطاكم كود الاستاذ محمد شغال معى تمام اما كود الاستاذ lionheart عند التجربة ظهر هذا الخطا رابط هذا التعليق شارك More sharing options...
lionheart قام بنشر سبتمبر 25, 2021 مشاركة قام بنشر سبتمبر 25, 2021 Maybe the problem is with the UNIQUE function as it works on newer versions of excel only رابط هذا التعليق شارك More sharing options...
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 رابط هذا التعليق شارك More sharing options...
فوزى فوزى قام بنشر سبتمبر 25, 2021 الكاتب مشاركة قام بنشر سبتمبر 25, 2021 شكرا للاستاذ محمد وللاستاذ قلب الاسد لجهودهم المستمرة ونشاطهم الواضح والداعم لنا ورزقهم الله الفردوس الاعلى 2 رابط هذا التعليق شارك More sharing options...
أ / محمد صالح قام بنشر سبتمبر 25, 2021 مشاركة قام بنشر سبتمبر 25, 2021 جميعا بإذن الله رابط هذا التعليق شارك More sharing options...
ميدو63 قام بنشر سبتمبر 26, 2021 مشاركة قام بنشر سبتمبر 26, 2021 الكود الاول والثانى روعة شكرا لكم 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان