yasse.w.2010 قام بنشر نوفمبر 23, 2020 مشاركة قام بنشر نوفمبر 23, 2020 السلام عليكم و رحمة الله و بركاته هذا الكود للستاذ سليم وقد اخذته من احدى المشاركات ارجو عند ترحيل البيانات ترحل معه تنسيق الصفحة شيت ( البيان ) من الوان و تنسيق للشيت شاكر لكم مجهودكم بيان.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر نوفمبر 23, 2020 أفضل إجابة مشاركة قام بنشر نوفمبر 23, 2020 تصحيح الكود Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Sub ADD_Sheets() Set T = Sheets("بيان") If T.AutoFilterMode Then T.Range("A8").AutoFilter Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 2 Then Exit Sub With T For i = 9 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("C" & i) & "'!A8)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("C" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets If Lr < 9 Then Exit Sub Set Flter_rg = T.Range("A8").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name = T.Name Or Spes_sh.Name = "Justify" Then Else Spes_sh.Range("A8").CurrentRegion.ClearContents Flter_rg.AutoFilter 3, Spes_sh.Name Flter_rg.SpecialCells(12).Copy Spes_sh.Range("A8").PasteSpecial (8) Spes_sh.Range("A8").PasteSpecial (xlPasteAll) End If Next If T.AutoFilterMode Then T.Range("A8").AutoFilter T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub Yasser_Filter.xlsm 4 رابط هذا التعليق شارك More sharing options...
yasse.w.2010 قام بنشر نوفمبر 23, 2020 الكاتب مشاركة قام بنشر نوفمبر 23, 2020 الف شكر لحضرتك يا استاذ سليم رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.