صقر الخليج قام بنشر نوفمبر 8, 2022 قام بنشر نوفمبر 8, 2022 السلام عليكم وبها نبدأ اي موضوع مرحبا محتاج اعمل تصفية لعدة صفوف في شيت واحد هل من الممكن عمل هذه الطريقة برمجيا المثال مرفق مع توضيح بالصورة نص السؤال جاهز مع الصورة.rar
محمد هشام. قام بنشر نوفمبر 19, 2022 قام بنشر نوفمبر 19, 2022 وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ...قد تم اضافة جميع الاكواد الى الملف المرفق Sub AutoF_Data() Dim c As Integer Dim MH As String Dim ws1 As Worksheet, ws2 As Worksheet Dim Y As ListObject, Y1 As ListObject, Y2 As ListObject Dim Lastrow As Long Lastrow = Feuil1.Range("H" & Rows.Count).End(xlUp).Row + 1 'خلية شرط معيار الفلترة MH = Sheets("Sheet1").Range("C1").Value If Len(Range("C1").Value) = 0 Then MsgBox "المرجوا ادخال معيار الفلترة" Exit Sub End If 'افراغ النطاق قبل الترحيل Range("H1:K" & Lastrow).Clear 'جدول البيانات Set ws1 = Sheets("Sheet1") 'مكان وضع البيانات المفلترة Set ws2 = Sheets("sheet1") 'في حالة الرغبة في اضافة شيت جديد وترحيل البيانات اليه 'Set ws2 = Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)) 'نسخ الى شيت موجود سابقا 'Set ws2 = Sheets("اسم الشيت") ''''''''''''''الجدول 1 Set Y = ws1.ListObjects(1) Application.ScreenUpdating = False 'تحديد عمود معيار الفلترة Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy 'تحديد موضع اللصق ws2.Cells(3, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''الجدول 2 Set Y = ws1.ListObjects(3) Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy ws2.Cells(12, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''الجدول 3''''''''''''''''''''''' Set Y = ws1.ListObjects(2) Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy ws2.Cells(21, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''نسخ رؤؤس الجداول''''''''''''''''' Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(3, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(12, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(21, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Feuil1.Activate ActiveSheet.ListObjects("Tableau3").Range.AutoFilter Field:=2 ActiveSheet.ListObjects("Tableau2").Range.AutoFilter Field:=2 ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2 'تنسيقات الجداول Call MH3 Application.ScreenUpdating = True End Sub بالتوفيق تصفية في شيت واحد.xlsm 3
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.