اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر (معدل)

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

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

 

تم تعديل بواسطه سليم حاصبيا
قام بنشر (معدل)

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

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

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

 

تم تعديل بواسطه سليم حاصبيا
  • Like 1
قام بنشر

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

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

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

 

قام بنشر
2 دقائق مضت, محمد لؤي said:

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

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

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

 

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

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

قام بنشر (معدل)

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

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

 

تم تعديل بواسطه ع_ حسام
شرح
قام بنشر
2 ساعات مضت, ع_ حسام said:

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

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

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

For i = 2 To Lr1

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

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
×
×
  • اضف...

Important Information