اختيار ونسخ صفوف بناء على قيمة خلية معينة

[عبدالرحمن بدوى]

السلام عليكم ورحمة الله وبركاته

تحية طيبة لاخوانى الاعزاء فى المنتدى الكريم

فى المرفق ملف يه مجموعة من البيانات

المطلوب :

كود ماكرو يقوم باختيار كل الصفوف التى تحتوى فى العمود E مثلا على كلمة production وينسخ كل هذه الصفوف

لانى ساقوم بعد ذلك بتصنيفها فى ملفات اخرى

حاولت عمل ذلك من خلال الfilter لكن يقوم بنسخ الكل

انا اريده فقط ان ينسخ الصفوف التى تحتوي على كلمة production

 

وشكرا

test.rar

[ابراهيم الحداد]

السلام عليكم ورحمة الله

جرب هذا الملف واخبرنى بالنتيجة

 

test.rar

[ياسر خليل أبو البراء]

بارك الله فيك أخي الغالي زيزو .. كود رائع وممتاز باستخدام المصفوفات

بالرغم من أنه يمكن حل المشكلة باستخدام الفلترة ثم نسخ الصفوف الظاهرة فقط أو باستخدام التصفية المتقدمة Advanced Filter ولكني أعشق التعامل مع المصفوفات

فقمت بنسخ كودك الرائع وتحويله لإجراء عام يمكن الاعتماد عليه بشكل عام ..

حيث يمكن التغيير في 6 أسطر كما هو موضح في التعليقات المصاحبة للكود ... بعدها يمكن تنفيذ الكود بسهولة

Sub Test()
    Dim wsSource    As Worksheet
    Dim wsTarget    As Worksheet
    Dim rng         As Range
    Dim rn          As Range
    Dim colCr       As Long
    Dim str         As String

    Set wsSource = Sheets("Sheet1")         'Source Sheet
    Set wsTarget = Sheets("Sheet2")         'Target Sheet

    Set rng = wsSource.Range("A3:E" & wsSource.Cells(Rows.Count, 1).End(xlUp).Row)      'Data Range
    Set rn = wsTarget.Range("A4")                                                       'Results Range

    colCr = 5                               'Criteria Column
    str = wsSource.Range("E1").Value        'Criteria String

    TransferDataUsingArrays wsSource, wsTarget, rng, rn, colCr, str
End Sub

Sub TransferDataUsingArrays(sSheet As Worksheet, tSheet As Worksheet, sRange As Range, tRange As Range, colCrit As Long, strCrit As String)
    Dim arr         As Variant
    Dim temp        As Variant
    Dim p           As Long
    Dim i           As Long
    Dim j           As Long
    Dim x           As Long

    Application.ScreenUpdating = False
        With tSheet
            With .Range(.Cells(tRange.Row, tRange.Column), .Cells(Rows.Count, sRange.Columns.Count))
                .ClearContents
                .Font.Bold = False
                .Font.ColorIndex = xlAutomatic
                .Interior.Color = xlNone
                .Borders.LineStyle = False
            End With
            With .Cells(tRange.Row, tRange.Column).Resize(, sRange.Columns.Count)
                .Value = sSheet.Cells(sRange.Row, sRange.Column).Resize(, sRange.Columns.Count).Value
                .Font.Bold = True
                .Font.Color = vbRed
                .Interior.Color = vbCyan
            End With
        End With
    
        arr = sRange.Value
        ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
        For i = 2 To UBound(arr, 1)
            If arr(i, colCrit) Like "*" & strCrit & "*" Then
                p = p + 1
                For j = 1 To UBound(arr, 2)
                    temp(p, j) = arr(i, j)
                Next j
            End If
        Next i
    
        If p > 0 Then tRange.Offset(1).Resize(p, UBound(temp, 2)).Value = temp
        tRange.Resize(p + 1, UBound(temp, 2)).Borders.LineStyle = True
    
        For i = sRange.Column To sRange.Columns.Count
            tRange.Offset(, 0 + x).ColumnWidth = sSheet.Columns(i).ColumnWidth
            x = x + 1
        Next i
    Application.ScreenUpdating = True
End Sub

 

[عبدالرحمن بدوى]

11 ساعات مضت, زيزو العجوز said:

السلام عليكم ورحمة الله

جرب هذا الملف واخبرنى بالنتيجة

 

test.rar

جزاكم الله خيرا ذلك هو المطلوب ولكنى اريد النسح فقط لأنى ساضع هذه البيانات فى ملف اخر غير الملف المقصود

ولن اضعها فى شيت اخر

9 ساعات مضت, ياسر خليل أبو البراء said:

بارك الله فيك أخي الغالي زيزو .. كود رائع وممتاز باستخدام المصفوفات

بالرغم من أنه يمكن حل المشكلة باستخدام الفلترة ثم نسخ الصفوف الظاهرة فقط أو باستخدام التصفية المتقدمة Advanced Filter ولكني أعشق التعامل مع المصفوفات

فقمت بنسخ كودك الرائع وتحويله لإجراء عام يمكن الاعتماد عليه بشكل عام ..

حيث يمكن التغيير في 6 أسطر كما هو موضح في التعليقات المصاحبة للكود ... بعدها يمكن تنفيذ الكود بسهولة

 

جزاكم الله خيرا

كيف يمكن عمل ذلك بالتصفية المتقدمة

وهل ساقوم باختيار الصفوف واحد واحد ام ساقوم باختيارهم جميعا

[عبدالرحمن بدوى]

للرفع