تعديل على كود الترحيل

[نسورالجو]

السلام عليكم المساعدة من الاخوة الافاضل في تعديل على كود الترحيل الشرح موجود داخل الشيت

ورقة.xlsm

[محمد يوسف ابو يوسف]

وعليكم السلام

تفضل

Sub ترحيل()

Dim wo As Integer
Application.ScreenUpdating = False
wo = [d1].End(xlUp).Row
Sheets(1).Activate
Range("a2:d1" & wo).Copy
Sheets(2).Activate
Range("a" & [b1048576].End(xlUp).Row + 2).PasteSpecial xlPasteValues
Sheets(1).Activate
Application.ScreenUpdating = True

End Sub

 

[نسورالجو]

شكرا استاذ محمد على تفاعلك السريع المطلوب ترحيل بشرطين بعمود تصنيف وعمود النوع بالترتيب في الشيت 2

[محمد يوسف ابو يوسف]

اخي 

طلبك غير واضح

 

1: هل تريد الترحيل اذا تحقق شرط  وان كان ذالك ما هو الشرط  ؟

2: ماذا تقصد بكلمة ترحيل بترتيب ...... هو بالفعل يتم الترحيل بالترتيب

[محي الدين ابو البشر]

ربما

Sub get_data()
    Dim i%
    Dim a
    Dim r
    r = 2
    With [Sheet1!A1].CurrentRegion.Rows
    .Range("k1:L1") = Array("head1", "head2")
        .Range("A:D").AdvancedFilter 2, , .Range("k1:L1"), True
        a = .Range("K1").CurrentRegion.Value2
        For i = 2 To UBound(a)
            .Range("K2").Value2 = a(i, 1):  .Range("l2").Value2 = a(i, 2)
            .Range("A:D").AdvancedFilter 1, .Range("K1:l2")
            .Item("2:" & .Count).Columns("A:D").Copy Sheet2.Cells(r + 2, 1)
            r = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
        Next
        .Parent.ShowAllData
        .Range("k1:L1").CurrentRegion.ClearContents
    End With
End Sub

 

[نسورالجو]

اولا  الشكر لك استاذنا بطبق الكود يظهر خطأ ( القصد  ترحيل البيانات في شيت الثان تنزل البيانات بالترتيب زي الصورة في الاعلي حتى لو نزلت بيانات في الشيت الاول بدون التريب)

ورقة.xlsm

[محي الدين ابو البشر]

عزيزي 

الكود يعمل بشكل جيد

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

.Range("Y1:Z1") = Array("head1", "head2")
.Range("A:D").AdvancedFilter 2, , .Range("Y1:Z1"), True

تحياتي

[نسورالجو]

شكرا استاذنا عملت ورقة جديدة وطبقت الكود نفس المشكلة 

ورقة عمل Microsoft Excel جديد.xlsm

[نسورالجو]

السلام عليكم استاذ محمد يوسف  انا للتو اخدت بالي انت الي بعت

طلبك غير واضح

1: هل تريد الترحيل اذا تحقق شرط  وان كان ذالك ما هو الشرط  ؟

2: ماذا تقصد بكلمة ترحيل بترتيب ...... هو بالفعل يتم الترحيل بالترتيب

طلبي في الشيت ده بس الكود بدائي لم يفي بالغرض

ورقة.xlsm

[محي الدين ابو البشر]

ورقة عمل Microsoft Excel جديد (1).xlsm

 First_one.xlsm

عندي مشكلة باللغة العربية استبدل بالشيت و بالكود 

[نسورالجو]

اعلم اثقلت عليك استاذنا هل من الممكن اضافة جملة اجمالي تحت كل حساب زي الصورة دي