ترحيل

[ع_ حسام]

أريد كود ترحيل البيانات المكتملة في الجدول فقط إلى الشيت رقم 2 

وشرح في المرفق 

ترحيل.rar

[سليم حاصبيا]

جرب هذا الماكرو

Sub Tarhil_Complete_Data()
Dim Ws1, Ws2 As Worksheet
Dim Lr1, Lr2, S, i As Integer
Dim RG1 As Range

Set Ws1 = Sheets("sheet1"): Set Ws2 = Sheets("sheet2")
Lr1 = Application.Max(Ws1.Range("a:a")) + 1

Set RG1 = Ws1.Range("a1:f" & Lr1)
 For i = 2 To Lr1
       Lr2 = Ws2.Cells(Rows.Count, 1).End(3).Row
        S = Application.CountA(RG1.Cells(i, 1).Resize(1, 6))
      If S = 6 Then _
       Ws2.Cells(Lr2 + 1, 1).Resize(1, 6).Value = RG1.Cells(i, 1).Resize(1, 6).Value
   Next
End Sub

 

تم تعديل أبريل 1, 2017 بواسطه سليم حاصبيا

[سليم حاصبيا]

ربما هذا الكود اسرع قليلاُ (للبيانات الكثيرة )

حيث يقوم يتحديد الصفوف المطلوبة ثم ينقلها دفعة واحدة الى المكان المقصود

Sub Tarhil_Complete_Data1()
Dim Ws1, Ws2 As Worksheet
Dim Lr1, S, i As Integer
Dim RG1, Temp_Range As Range

Set Ws1 = Sheets("sheet1"): Set Ws2 = Sheets("sheet2")
Lr1 = Application.Max(Ws1.Range("a:a")) + 1

Set RG1 = Ws1.Range("A1:F" & Lr1)
 For i = 2 To Lr1

        S = Application.CountA(RG1.Cells(i, 1).Resize(1, 6))
        If S = 6 Then
                    If Temp_Range Is Nothing Then
                       Set Temp_Range = RG1.Cells(i, 1).Resize(1, 6)
                    Else
                        Set Temp_Range = Union(Temp_Range, _
                        RG1.Cells(i, 1).Resize(1, 6))
                     End If
         End If
 Next
    If Temp_Range Is Nothing Then Exit Sub
Temp_Range.Copy Ws2.Range("a2")
Set Temp_Range = Nothing
End Sub

 

تم تعديل أبريل 1, 2017 بواسطه سليم حاصبيا

[محمد لؤي]

السلام عليكم - جزيت خيرا استاذ سليم

ويحتوي هذا الكود الثاني على ميزة اخرى غير موجودة بالكود الاول وهي :

عدم الترحيل مرة ثانية عند الضغط مرة ثانية على زر الترحيل

 

[سليم حاصبيا]

2 دقائق مضت, محمد لؤي said:

السلام عليكم - جزيت خيرا استاذ سليم

ويحتوي هذا الكود الثاني على ميزة اخرى غير موجودة بالكود الاول وهي :

عدم الترحيل مرة ثانية عند الضغط مرة ثانية على زر الترحيل

 

نستطيع بالكود الاول ان تفعل نفس الشيء وذلك بإفراغ محتويات الورقة 2 ابتداء من الصف الثاني قبل عملية الترحيل

Ws2.range("A2:F1000").ClearContents

[ع_ حسام]

الكود الثاني أحسن 

مشكلة في الكود تتمثل في ترحيل البياانت من 1 إلى 14 فقط  

 

تم تعديل أبريل 2, 2017 بواسطه ع_ حسام
شرح

[سليم حاصبيا]

42 دقائق مضت, ع_ حسام said:

الكود الثاني أحسن 

مشكلة في الكود تتمثل في ترحيل البياانت من 1 إلى 14 فقط  

 

ارفع الملف لاكتشاف الخطأ

[ع_ حسام]

 عذرا أنا أسف الخطأ من الأوفيس  من عندي  وتم معالجته  شكرا لك

سطر المسح   Ws2.range("A2:F1000").ClearContents أين يوضع 

[سليم حاصبيا]

2 ساعات مضت, ع_ حسام said:

 عذرا أنا أسف الخطأ من الأوفيس  من عندي  وتم معالجته  شكرا لك

سطر المسح   Ws2.range("A2:F1000").ClearContents أين يوضع 

فبل هذه العبارة في سطر مستقل

For i = 2 To Lr1