ترحيل بيانات بين فترتين

[ريان أحمد]

السلام عليكم

 

 

الرجاء ترحيل البيانات من الورق 01 إلى 02 بين تاريخين

Classeur1.rar

[عبدالله المجرب]

سوال

اي الاعمدة هي المعتمدة في اعتماد تاريخ الترحيل عليها  E او D

================================

انا اعتمدت على E

ضع هذا الكود في زر أمر في الورقة  Feuil1 

 

Sub Abu_Ahmed()
Dim I As Integer, MyDat1 As Date, MyDat2 As Date
Set Mysh = Sheets("Feuil2")
MyDat1 = Mysh.[E5]: MyDat2 = Mysh.[F5]
For I = 2 To [A10000].End(xlUp).Row
If Cells(I, 5) >= MyDat1 And Cells(I, 5) <= MyDat2 Then
Cells(I, 1).Resize(1, 41).Copy Mysh.Range("A" & Mysh.[A10000].End(xlUp).Row + 1)
End If
Next
Set Mysh = Nothing
End Sub

تم تعديل فبراير 2, 2013 بواسطه عبدالله المجرب

[حسين العصلوجى]

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

اليومية.rar

[ريان أحمد]

السلام عليكم

شكرا أستاذي على الملف ولكن هل أستطيع تغيير مكان وضع الزر في الورقة 2

[ريان أحمد]

up

[احمد عبد الناصر]

السلام عليكم

 

بعد اذن الاستاذ  عبدالله المجرب .

 

جرب هذا الكود

 

Sub Abu_Ahmed()
Dim I As Integer, MyDat1 As Date, MyDat2 As Date
Set Mysh = Sheets("Feuil2")
Set sh = Sheets("Feuil1")
MyDat1 = Mysh.[E5]: MyDat2 = Mysh.[F5]
For I = 2 To sh.[A10000].End(xlUp).Row
If sh.Cells(I, 5) >= MyDat1 And sh.Cells(I, 5) <= MyDat2 Then
sh.Cells(I, 1).Resize(1, 41).Copy Mysh.Range("A" & Mysh.[A10000].End(xlUp).Row + 1)
End If
Next
Set Mysh = Nothing
Set sh = Nothing
End Sub

 

 

تحياتي

[ريان أحمد]

السلام عليك أخي

 

أحمد عبد الناصر الكود يعمل ولكن عند الضغط مرتيم خطأ يأتي بالبيلنات مرتين وثلاثة حسب الضغط على الزر خطأ

 

أريد يجلب البيانات مرة واحدة إى في حالة إدخال تاريخ جديد

[احمد عبد الناصر]

اخي ريان

 

جرب هذا الكود : يعمل عند ادخال تاريخ جديد في الخلية F5 .

 

ضعه في كود الصفحة  Feuil2

 

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = [F5].Address Then
Abu_Ahmed
End If
End Sub

Sub Abu_Ahmed()
Dim I As Integer, MyDat1 As Date, MyDat2 As Date
Set Mysh = Sheets("Feuil2")
Set sh = Sheets("Feuil1")
xx = Mysh.Cells(Rows.Count, "a").End(xlUp).Row
If xx > 11 Then Mysh.Range("a12:ao" & xx).ClearContents
MyDat1 = Mysh.[E5]: MyDat2 = Mysh.[F5]
For I = 2 To sh.Cells(Rows.Count, "a").End(xlUp).Row
If sh.Cells(I, 5) >= MyDat1 And sh.Cells(I, 5) <= MyDat2 Then
sh.Cells(I, 1).Resize(1, 41).Copy Mysh.Range("A" & Mysh.Cells(Rows.Count, "a").End(xlUp).Row + 1)
End If
Next
Set Mysh = Nothing
Set sh = Nothing
End Sub
 

تحياتي

[ريان أحمد]

شكرا جزيلا أخي  هنا جزءية صغيرة في الكود كيف أغيرها وهي الخلية e5    و f5 المعنيتين بالتاريخ هل أستطيع ان أغير مكان تواجدهم يعني ليس شرطا ان أصع الخليتين في نفس مكان وصع الجدول

[احمد عبد الناصر]

هذا السطر يضبط خلايا التاريخ  بامكانك تغيرهما كيما تريد

 

MyDat1 = Mysh.[E5]: MyDat2 = Mysh.[F5]

 

تحياتي

[ريان أحمد]

أريد أن أغير الورقة التي فيها فترة التاريخ

[ريان أحمد]

up

[عبدالله المجرب]

السلام عليكم 

جرب الكود بعد التعديل 

لن تحتاج الى خلايا للتاريخ

Sub Abu_Ahmed()
On Error GoTo 1
Dim I As Integer, MyDat1 As Date, MyDat2 As Date, AbuAhmed As Boolean
MyDat1 = CDate(InputBox("ضع تاريخ البداية هنا", "إدخال"))
MyDat2 = CDate(InputBox("ضع تاريخ النهاية هنا", "إدخال"))
AbuAhmed = True: Set Mysh = Sheets("Feuil2"): Set sh = Sheets("Feuil1")
For I = 2 To sh.[A10000].End(xlUp).Row
If sh.Cells(I, 5) >= MyDat1 And sh.Cells(I, 5) <= MyDat2 Then
sh.Cells(I, 1).Resize(1, 41).Copy Mysh.Range("A" & Mysh.[A10000].End(xlUp).Row + 1)
End If
Next
Set Mysh = Nothing: Set sh = Nothing
1:
If AbuAhmed Then MsgBox "تم الترحيل": Exit Sub
MsgBox "خطاء في ادخال التاريخ"
End Sub

[ريان أحمد]

شكرا على هذا الإبداع أستاذي الفاضل

 

لكن عندما إدخل رقم 01 مثلا في الخلية التي في الرسالة يقوم بقبولها يعني أريد ضبط إدخال تاريخ فقط

[ريان أحمد]

up

[ريان أحمد]

للرفع

[عبدالله المجرب]

السلام عليكم

جرب هذا التعديل

 

Sub Abu_Ahmed()
On Error GoTo 1
Dim I As Integer, MyDat1 As Date, MyDat2 As Date, AbuAhmed As Boolean
MyVal1 = InputBox("ضع تاريخ البداية هنا", "إدخال")
MyVal2 = InputBox("ضع تاريخ النهاية هنا", "إدخال")
If Len(MyVal1) <> 10 Or Len(MyVal2) <> 10 Then Exit Sub
MyDat1 = CDate(MyVal1): MyDat2 = CDate(MyVal2)
AbuAhmed = True: Set Mysh = Sheets("Feuil2"): Set sh = Sheets("Feuil1")
For I = 2 To sh.[A10000].End(xlUp).Row
If sh.Cells(I, 5) >= MyDat1 And sh.Cells(I, 5) <= MyDat2 Then
sh.Cells(I, 1).Resize(1, 41).Copy Mysh.Range("A" & Mysh.[A10000].End(xlUp).Row + 1)
End If
Next
Set Mysh = Nothing: Set sh = Nothing
1:
If AbuAhmed Then MsgBox "تم الترحيل": Exit Sub
MsgBox "خطاء في ادخال التاريخ"
End Sub

[رجب جاويش]

بعد اذن أخى وأستاذى الحبيب / عبد الله المجرب

لاثراء الوضوع

هذا تعديل آخر

ربما يفيد

 

Sub Abu_Ahmed()
On Error GoTo 1
Dim I As Integer, AbuAhmed As Boolean
MyVal1 = InputBox("ضع تاريخ البداية هنا", "إدخال")
MyVal2 = InputBox("ضع تاريخ النهاية هنا", "إدخال")
If Not IsDate(MyVal1) Or Not IsDate(MyVal2) Then GoTo 1
AbuAhmed = True: Set Mysh = Sheets("Feuil2"): Set sh = Sheets("Feuil1")
For I = 2 To sh.[A10000].End(xlUp).Row
If CDate(sh.Cells(I, 5)) >= MyVal1 And CDate(sh.Cells(I, 5)) <= MyVal1 Then
sh.Cells(I, 1).Resize(1, 41).Copy Mysh.Range("A" & Mysh.[A10000].End(xlUp).Row + 1)
End If
Next
Set Mysh = Nothing: Set sh = Nothing
1:
If AbuAhmed Then MsgBox "تم الترحيل": Exit Sub
MsgBox "خطأ في ادخال التاريخ"
End Sub

 

Classeur1.rar

[ريان أحمد]

أستاذي رجب شاوش شكرا على هذا الإثراء للموضوع الكود يعمل بشكل رائع

 

 

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

[رجب جاويش]

أخى الفاضل / ريان أحمد

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

 

وعلى فكرة لقبى جاويش وليس شاوش

 

وبالنسبة للتعديل الذى قمت به هو تعديل بسيط جدا على كود أستاذى الحبيب / عبد الله المجرب

لذا يرجع الفضل له

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

[ريان أحمد]

المعذرة على هذا الخطأ وشكرا لكما فأنتما وجهان لعملة واحدة وهي المساعدة وتقديم العون للأعضاء

 

جزاكما الله كل خير وإن شاءالله مزيدا من التقدم والرقي