tlayt kamal قام بنشر فبراير 12, 2020 مشاركة قام بنشر فبراير 12, 2020 المطلوب فضلا وليس امرا ماكرو عند ادخال رقم العميل في H2 و التاريخ من في I2 والتاريخ الى في J2 ترحل البيانات من شيت1 الى شيت2 حفظكم الله DT.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر فبراير 12, 2020 أفضل إجابة مشاركة قام بنشر فبراير 12, 2020 جرب هذا الكود Option Explicit Private Sub Worksheet_Activate() fil_dat_val End Sub '+++++++++++++++++++++++++++++++++++ Sub fil_dat_val() Application.ScreenUpdating = False Dim I%: I = 6 Dim arr Dim rg As Object Set rg = CreateObject("system.collections.arraylist") With rg Do Until Sheets("sheet1").Range("B" & I) = vbNullString If Not .contains(Sheets("sheet1").Range("A" & I).Value) Then _ .Add Sheets("sheet1").Range("A" & I).Value I = I + 1 Loop .Sort arr = .toarray arr = Join(arr, ",") End With With Sheets("sheet2").Range("H2").Validation .Delete .Add xlValidateList, Formula1:=arr End With End Sub '============================== Sub get_values() Dim rg As Object, I%, m%, kY Dim Sh1 As Worksheet, Sh2 As Worksheet I = 6 Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2") Set rg = CreateObject("Scripting.dictionary") Sh2.Range("a6").CurrentRegion.Offset(1).Clear With Sh1 Do Until Not IsNumeric(.Range("a" & I)) If .Range("A" & I) = Sh2.Range("h2") _ And .Range("C" & I) >= Sh2.Range("I2") _ And .Range("C" & I) <= Sh2.Range("J2") Then rg(m) = _ .Range("C" & I).Value & "*" & _ .Range("D" & I).Value & "*" & _ .Range("E" & I).Value m = m + 1 End If I = I + 1 Loop End With If rg.Count = 0 Then GoTo End_Me m = 6 For Each kY In rg.keys Sh2.Cells(m, 1).Resize(, 3) = _ Split(rg(kY), "*"): m = m + 1 Next With Sh2.Range("A6:C" & m - 1) .Value = .Value .InsertIndent 1 .Borders.LineStyle = 1 .Font.Size = 14 End With End_Me: Application.ScreenUpdating = True Set rg = Nothing End Sub Saerch_by_date.xlsm 3 رابط هذا التعليق شارك More sharing options...
tlayt kamal قام بنشر فبراير 12, 2020 الكاتب مشاركة قام بنشر فبراير 12, 2020 حفظك الله استاذ سليم هذا ما اريد بالظبط روعة رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان