الترحيل حسب ايام الشهر مع ترحيل ارقام خاصة الى شيت خاص

[محمد لؤي]

السلام عليكم - حياكم الله

ممكن الترحيل حسب الشهر مع بقاء البيانات في الشيت ،

وطلب اخر مهم :

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

 

الترحيل حسب الشهر.rar

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

جرب مبدئباً هذا  الماكرو

Sub filter_for_me()
Dim My_rg As Range
Dim my_sht As Worksheet
Dim lr As Long
Dim ws9, ws10, ws11, ws12, ws1, ws2, ws3, ws4 As Worksheet
Set my_sht = Sheets("كل الاشهر")
Set ws9 = Sheets("شهر9-2016"): Set ws10 = Sheets("شهر10-2016")
Set ws11 = Sheets("شهر11-2016"): Set ws12 = Sheets("شهر12-2016")
Set ws1 = Sheets("شهر1-2017"): Set ws2 = Sheets("شهر2-2017")
Set ws3 = Sheets("شهر3-2017"): Set ws4 = Sheets("شهر4-2017")
            Application.ScreenUpdating = False
lr = my_sht.Cells(Rows.Count, 1).End(3).Row
Set My_rg = my_sht.Range("A1:H" & lr)
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "9/30/2016")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws9.Range("A1").PasteSpecial Paste:=xlPasteAll
my_sht.Range("A1:H" & lr).AutoFilter
 My_rg.AutoFilter
'''''''''''''''''''''''''''''
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "10/31/2016")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws10.Range("A1").PasteSpecial Paste:=xlPasteAll
  My_rg.AutoFilter
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "11/30/2016")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws11.Range("A1").PasteSpecial Paste:=xlPasteAll
 My_rg.AutoFilter
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "12/31/2016")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws12.Range("A1").PasteSpecial Paste:=xlPasteAll
 My_rg.AutoFilter
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "1/31/2017")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws1.Range("A1").PasteSpecial Paste:=xlPasteAll
 My_rg.AutoFilter
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "2/28/2016")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws2.Range("A1").PasteSpecial Paste:=xlPasteAll
 My_rg.AutoFilter
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "3/31/2016")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws3.Range("A1").PasteSpecial Paste:=xlPasteAll
 My_rg.AutoFilter
'===================================
My_rg.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(1, "4/30/2016")
My_rg.SpecialCells(xlCellTypeVisible).Copy
ws4.Range("A1").PasteSpecial Paste:=xlPasteAll
 My_rg.AutoFilter
        Application.ScreenUpdating = True
End Sub

 

[محمد لؤي]

شيخ واستاذ سليم المحترم - جزيت خيرا

تمام - الكود شغال 100 %

استاذ شغلة واحده يرحم والديك

ترحيل الارقام الخاصة الى شيت السيارات الخاصة

تم تعديل مارس 11, 2017 بواسطه محمد لؤي

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

1 ساعه مضت, محمد لؤي said:

شيخ واستاذ سليم المحترم - جزيت خيرا

تمام - الكود شغال 100 %

تبقى شغلة واحده وهي _ السيارات ارقام السيارات الخاصة ترحل فقط الى شيت (السيارات الخاصة) وارقامها موضحة في شيت (كل الاشهر)

مشكور استاذ - الله يحفظك وبارك الله في وقتك ، مع الاشارة 

بانه توجد اشهر في سنة (2016) واشهر في سنة (2017) وانشاء اشهر جديدة الى نهاية سنة (2017)

انسخ هذه المعادلة الى الخلية A2 من الورقة السيارات الخاصة واسحبها يميناً حتى العامود H ثم الى اسفل  قدر ما تريد من الصفوف

=IF('كل الاشهر'!$J8="","",INDEX('كل الاشهر'!A$2:A$4364,MATCH('كل الاشهر'!$J8,'كل الاشهر'!$E$2:$E$4364,0)))

     

[محمد لؤي]

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

أمر مهم وهو :  يوجد برقم السيارة اكثر من نقلة ، فمثلاً الرقم (555042) لديه (5) نقلات والمعادلة نقلت نقلة واحدة 

الله يرضى عليك استاذ ممكن المراجعة - الله يبارك في وقتك

 

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

هذا الماكرو يقوم بما تريد

Sub advanced_Salim()

Dim My_rg As Range
Dim My_Sht_Source As Worksheet
Dim My_Sht_Target As Worksheet
Dim Lr, Lra As Long, x As Integer

Set My_Sht_Source = Sheets("كل الاشهر")
Set My_Sht_Target = Sheets("السيارات الخاصة")

My_Sht_Target.Cells.Clear
Lr = My_Sht_Source.Cells(Rows.Count, 1).End(3).Row
Set My_rg = My_Sht_Source.Range("A1:H" & Lr)
x = Application.CountA(My_Sht_Source.Range("j8:j500")) + 7

 Lra = My_Sht_Target.Cells(Rows.Count, 1).End(3).Row
     If Lra = 1 Then Lra = 2
  For k = 8 To x
     My_Sht_Source.Range("xfd2").Formula = "=E2=$J$" & k
     '==============================
    My_rg.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("كل الاشهر").Range("xfd1:xfd2"), CopyToRange:=My_Sht_Target.Range("A" & Lra)
     Lra = My_Sht_Target.Cells(Rows.Count, 1).End(3).Row + 2
    
Next
End Sub

 

[محمد لؤي]

السلام عليكم - جزيت خيرا - بارك الله فيك وفي اهلك ومالك 

يرحم والديك

تمام اكثر من المطلوب - وخاصة ترتيب كل مجموع سيارة يفرق بينهم فراغ لاجل الجمع

تمام