2saad قام بنشر يناير 6 مشاركة قام بنشر يناير 6 اخواني اعضاء المنتدي الكرام السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير محتاج كود فلترة من شيت 1 الي شيت 2 بناء علي القائمة المنسدلة الملونة باللون الأصفر في شيت 2 ابتداء من C22 الي AD ولكم جزيل الشكرتجربة.xlsm رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يناير 6 مشاركة قام بنشر يناير 6 (معدل) وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim wb As Workbook, WS As Worksheet, dest As Worksheet Set wb = ThisWorkbook: Set WS = wb.Sheets("Sheet1"): Set dest = wb.Sheets("Sheet2") Dim j&, col&, ligne&, r As String Dim Rng As Range: col = 12: r = dest.[B19] ligne = WS.Cells(Rows.Count, col).End(xlUp).Row With Application .ScreenUpdating = False dest.Range("C22", Range("AD" & Rows.Count).End(4)).ClearContents For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If Next j If Application.WorksheetFunction.CountA(dest.Range("C22:AD22")) = 0 Then MsgBox "غير موجود" & " / " & r, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True End With End Sub تجربة 2.rar تم تعديل يناير 6 بواسطه محمد هشام. 2 1 رابط هذا التعليق شارك More sharing options...
2saad قام بنشر يناير 6 الكاتب مشاركة قام بنشر يناير 6 شكرا جزيلا يا استاذ محمد رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر يناير 7 مشاركة قام بنشر يناير 7 ملاحظة : في حالة قمت بحدف عناوين الاعمدة سيتم نسخ البانات بعد اخر خلية فارغة في عمود C ولتثبيت اللصق في الصف 22 ما عليك هو تعديل الصفوف التالية For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) If dest.[C22] = Empty Then dest.[C22].Resize(1, 28).Value = Rng.Value Else: dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If End If ''''''''''''''''''''''''''''''او'''''''''''''''''''''''''''' Dim dlr As Long For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then dlr = dest.Cells(Rows.Count, "C").End(xlUp).Row If dlr < 21 Then dlr = 21 Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Range("C" & dlr).Offset(1).Resize(1, 28).Value = Rng.Value End If Next j 1 1 رابط هذا التعليق شارك More sharing options...
2saad قام بنشر يناير 7 الكاتب مشاركة قام بنشر يناير 7 الله يبارك فيك وفي أمثالك رابط هذا التعليق شارك 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.