مطلوب ترحيل من فترة الى فترة

[صلاح الصغير]

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

الاساتذة الكرام

المطلوب فى المرفق هو الترحيل من ورقة الى ورقة بشرط بين تاريخين

رجاء كود و ليس معادلة لكثرة البيانات

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

03.rar

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

وعليكم السلام أخي الكريم صلاح

راجع الرابط التالي عله يفيدك

https://www.officena.net/ib/topic/68426-تصفية-متقدمة-بين-تاريخين-وفق-عدة-معايير-بالأكواد-والمعادلات-للتاريخ/?do=findComment&comment=445127

[أبو حنــــين]

lمرحبا اخي صلاح

ربما هذا الكود يفي بالغرض

Sub CopyTofilter()

Dim SH1 As Worksheet, SH2 As Worksheet, R As Integer, T As Integer, Date1 As Double, Date2 As Double
R = 1
Set SH1 = Sheets("filter"): Set SH2 = Sheets("all data")
Date1 = SH1.Range("L2"): Date2 = SH1.Range("M2")

SH1.Range("A2:K" & SH1.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row) = ""
Application.ScreenUpdating = False
        For T = 2 To SH2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
        Select Case SH2.Cells(T, 2).Value2: Case Date1 To Date2
        R = R + 1
        SH2.Range("A" & T).Resize(, 11).Copy
        SH1.Range("A" & R).PasteSpecial xlPasteValues
End Select
Next
Application.ScreenUpdating = True

End Sub

 

[صلاح الصغير]

شكرا ا / بو حنين

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

[صلاح الصغير]

ا / ابو حنين

عذرا حدث الخطأ التالى مع كثرة الصفوف 

35000 صف

 

[أبو حنــــين]

مرحبا

هل اخذت صورة للرسالة التي ظهرت عند الخطأ ؟

[صلاح الصغير]

نعم

run time error

overflow

[أبو حنــــين]

جرب أن تغير السطر التالي

For T = 2 To SH2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
بهذا السطر واخبرني بالنتيجة
For T = 2 To 35000

 

[صلاح الصغير]

نفس الخطأ فى السطر الجديد

 

[أبو حنــــين]

غير في التصريح هذا السطر

Dim T As Integer

بهذا السطر

Dim T As Long

 

[صلاح الصغير]

تم حل المشكلة

و هل هذا معناه انه لن يعمل الا لصف 35000 فقط

و انا ازود الرقم من الكود

[أبو حنــــين]

قم بارجاع السطر

For T = 2 To SH2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row

[صلاح الصغير]

فعلا جربته و لم يعمل الا لصف 35000

 

هل هناك تعديل ليعمل لاخر صف فيه بيانات فى ورقة all data

تم تعديل أغسطس 28, 2016 بواسطه صلاح الصغير

[أبو حنــــين]

غير 

Dim R As Integer

بهذا السطر

Dim R As Long

 

 

•  
• اقتباس
•  
• تعديل

Quote this

و تأكد جيدا من اسم الورقة 

SH2

[صلاح الصغير]

ا / ابو حنين

شكرا و جزاك الله خيرا

و هو المطلوب اثباته

شكرااااااااااااااااااا

[أبو حنــــين]

الحمد لله

 

[صلاح الصغير]

ا / ابو حنين

لو ممكن اطمع فى طريقة لتسريع الكود لو امكن

البيانات المنقولة قد تصل الى 50000 صف

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

أخي الكريم صلاح

وضعت لك رابط فيه كود مشابه لما سأقدمه الآن وقد كان الحل بين يديك (نفس الفكرة تقريباً مع بعض التعديلات ليتناسب مع ملفك)

جرب الكود التالي عله يفي بالغرض ويكون أسرع في التعامل مع البيانات

Sub Data_Between_Two_Dates()
    Dim Ws As Worksheet, Sh As Worksheet
    Dim Arr, Temp
    Dim I As Long, P As Long, T As Long
    Dim startDate As Date, endDate As Date

    Set Ws = Sheets("all data"): Set Sh = Sheets("filter")
    Arr = Ws.Range("A2:K" & Ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
    startDate = Sh.Range("L2").Value2: endDate = Sh.Range("M2").Value2
    ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    
    For I = LBound(Arr, 1) To UBound(Arr, 1)
        If Arr(I, 2) >= startDate And Arr(I, 2) <= endDate Then
            For T = 1 To 11
                Temp(P + 1, T) = Arr(I, T)
            Next T
            
            P = P + 1
        End If
    Next I

    Sh.Range("A2").Resize(P, UBound(Temp, 2)).Value = Temp
End Sub

 

[صلاح الصغير]

ا / ياسر

كالعادة دائما

مش عارف اقولك ايه

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

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

أخي الكريم صلاح

مش عارف تقول ايه وقلت "جزاك الله خيراً"

كدا إنت قلت أهو .. لو اطلعت على الموضوع في الرابط في أول مرة كان هيفيدك في الحل .. بس أعمل ايه مفيش كلام بيتسمع

ولا أقولك بلاش لو عشان دي بتفتح أبواب الشيطان . نقول " قدر الله وما شاء فعل ، ولعله خير ..

تقبل تحياتي