حساب و ترحيل بتاريخ معين

[ابو منذر عبد الله]

أخوكم في الله يريد مساعدتكم 

دوال حساب و ترحيل بيانات بتاريخ او بين تاريخين ل 1400 زبون

و بارك الله فيكم

مشاركة مكررة ... تــم بالفعل حذف المشاركة الأخرى , يكفيك كتابة للـــــرفع لطلب الرد ولا تقوم بفتح مشاركات جديدة لمشاركة قديمة موجودة بالفعل والا ستحذف جميع المشاركات وعليك الإطلاع على قواعد وقوانين الإشتراك بالمنتدى

Classeur1 (2).xlsx

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

ليست المرة الأولى التي اقول فيها "ممنوع دمج الخلايا حيث يوجد معادلات"

تم ازالة الدمج  و لن اقبل بأي مشاركة فيها خلايا مدمجة و تتطلب معادلات بعد الآن

الملف مرفق

 

 

makl.xlsx

[ابو منذر عبد الله]

السلام عليكم

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

من فضلك لا تكرر نفس المشاركات والا ستحذف جميع المشاركات

كراء 1.xlsx

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

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

Option Explicit
    Dim LC%, LD%, LM%, k%, i%, m%
    Dim last_col%, Tar_col%
    
    Dim RC As Range, RD As Range, RM As Range
    Dim R_date As Range, Fd1 As Range
    
    Dim Date1 As Date, Date2 As Date
    Dim Max_date As Date
    Dim Min_date As Date

'+++++++++++++++++++++++++++++++++++
Sub General_Macro()
Set R_date = Cap.Range("E4").Resize(, 100)
last_col = Cap.Cells(4, Columns.Count).End(1).Column
If last_col < 6 Then Exit Sub
Min_date = 100000: Max_date = 1
 
 For i = 6 To last_col
  If Cap.Cells(4, i) > Max_date Then
   Max_date = Cap.Cells(4, i)
  End If
  If Cap.Cells(4, i) < Min_date Then
   Min_date = Cap.Cells(4, i)
  End If
 Next
 
Set RC = Cap.Range("A6").CurrentRegion
    LC = RC.Rows.Count
    
Set RD = Daay.Range("A6").CurrentRegion
    LD = RD.Rows.Count
Set RM = More.Range("A6").CurrentRegion
    LM = RM.Rows.Count
End Sub
'+++++++++++++++++++++++++++++++++++++
Sub One_day()
General_Macro
If last_col < 6 Then Exit Sub
 If Daay.Range("A6") <> "" Then
    Daay.Range("A6"). _
    Resize(LD + 1, 6).ClearContents
 End If
 If Not IsDate(Daay.Range("b2")) Or _
    Daay.Range("B2") < Min_date Or _
    Daay.Range("B2") > Max_date Then
    Date1 = Min_date
    Daay.Range("B2") = Date1
 End If
 Date1 = Daay.Range("B2")
 m = 6
 Set Fd1 = R_date.Find(Date1, lookat:=1)
  If Not Fd1 Is Nothing Then
   Daay.Cells(4, 6) = Date1
   Tar_col = Fd1.Column
    For k = 6 To LC + 5
        If Cap.Cells(k, Tar_col) <> "" Then
        Daay.Cells(m, 1).Resize(, 5).Value = _
        Cap.Cells(k, 1).Resize(, 5).Value
        Daay.Cells(m, 6) = Cap.Cells(k, Tar_col)
        m = m + 1
     End If
   Next
  End If

End Sub
'+++++++++++++++++++++++++++++++++++++++
Sub More_days()
General_Macro
Dim X%, Periode%

If last_col < 6 Then Exit Sub
 If More.Range("A6") <> "" Then
    More.Range("A6"). _
    Resize(LM + 1, 6).ClearContents
 End If
  More.Cells(4, "F").Resize(, 100).ClearContents
 If Not IsDate(More.Range("B2")) Or _
    More.Range("B2") < Min_date Or _
    More.Range("B2") > Max_date Then
    Date1 = Min_date
    More.Range("B2") = Date1
 End If
 Date1 = More.Range("D2")
 If Not IsDate(More.Range("D2")) Or _
    More.Range("D2") < Min_date Or _
    More.Range("D2") > Max_date Then
    Date2 = Max_date
    More.Range("D2") = Date2
 End If
 Date1 = Application.Min(More.Range("B2,D2"))
 Date2 = Application.Max(More.Range("B2,D2"))
 More.Range("B2") = Date1
 More.Range("D2") = Date2
 Periode = Date2 - Date1 + 1
  
 With More.Cells(4, "F")
   For i = 1 To Periode
    .Offset(, i - 1) = Date1 + i - 1
   Next
 End With

 m = 6
 Set Fd1 = R_date.Find(Date1, lookat:=1)
 If Not Fd1 Is Nothing Then
     Tar_col = Fd1.Column
    For k = 6 To LC + 5
  
      X = Application.CountA(Cap.Cells(k, Tar_col) _
      .Resize(, Periode))
      If X > 0 Then
        More.Cells(m, 1).Resize(, 5).Value = _
        Cap.Cells(k, 1).Resize(, 5).Value
        
        More.Cells(m, 6).Resize(, Periode).Value = _
        Cap.Cells(k, Tar_col).Resize(, Periode).Value
        m = m + 1
      End If
    Next k
 
 End If

End Sub

الملف مرفق

Kara3_21.xlsm

[ابو منذر عبد الله]

بارك الله فيك استاذ منكم نتعلم و آسف على التكرار و لن اعيدها 

استاذ الماكرو يجلب 5 زبائن فقط

 

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

ما هو الموجود في الشيت "قائمة الزبائن" 5 زبائن فقط

حاول اضافة زبائن اخرى و ترى النتائج

كما في هذا الملف

Kara3_22.xlsm

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

في الملف الأخير تم تعديل الماكرو ليمسح البيانات القديمة (أعد تجميله) "Kara3_22.xlsm"

[ابو منذر عبد الله]

بوركت و زادك الله من علمه