تعديل علي كود ترحيل

[2saad]

اخواني الأعزاء بعد سلام الله عليكم ورحمة الله وبركاته

الكود المرفق يقوم بترحيل بيانات التلاميذ والتلميذات الذين لهم دور ثان 

محتاج اعدل فيه بحيث بحيث يرحل بيانات التلاميذ والتلميذات الذين لهم دور ثان  وكمان ( غ )

Sub Filter_and_copy_with_condition() '********** MOHAMMED HICHAM 02/03/2024****************
 Dim d, j
 Dim Search As Range, clé As String, IRow As Long
 Dim WS As Worksheet:       Set WS = Worksheets("cheet4")
 Dim F As Worksheet:        Set F = Worksheets("شيت الدور الثاني صف رابع ")

    d = 9:   j = 16:   clé = "*" & F.[B1]
   
   IRow = WS.Range("DZ:DZ").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
   
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
 
    If Len([B1].Value) = 0 Then: Exit Sub
    Set Search = WS.Range("DZ16:DZ" & IRow).Find(clé, LookIn:=xlValues, lookat:=xlWhole)
    If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub
   
    F.Range("C10:O" & Rows.Count).ClearContents
    Do Until IsEmpty(WS.Range("DZ" & j))
        If WS.Range("DZ" & j) Like clé Then
            d = d + 1
            F.Cells(d, 3).Value = WS.Cells(j, 3).Value
            F.Cells(d, 4).Value = WS.Cells(j, 4).Value
            F.Cells(d, 5).Value = WS.Cells(j, 5).Value
            F.Cells(d, 6).Value = WS.Cells(j, 6).Value
            F.Cells(d, 7).Value = WS.Cells(j, 7).Value
            F.Cells(d, 8).Value = WS.Cells(j, 8).Value
            F.Cells(d, 9).Value = WS.Cells(j, 9).Value
            F.Cells(d, 10).Value = WS.Cells(j, 10).Value
            F.Cells(d, 11).Value = WS.Cells(j, 11).Value
            F.Cells(d, 12).Value = WS.Cells(j, 12).Value
            F.Cells(d, 13).Value = WS.Cells(j, 13).Value
            F.Cells(d, 14).Value = WS.Cells(j, 14).Value
            F.Cells(d, 15).Value = WS.Cells(j, 130).Value
            F.Cells(d, 18).Value = WS.Cells(j, 28).Value
            F.Cells(d, 21).Value = WS.Cells(j, 40).Value
            F.Cells(d, 24).Value = WS.Cells(j, 52).Value
            F.Cells(d, 27).Value = WS.Cells(j, 64).Value
            F.Cells(d, 30).Value = WS.Cells(j, 76).Value
            F.Cells(d, 33).Value = WS.Cells(j, 88).Value
            F.Cells(d, 36).Value = WS.Cells(j, 100).Value
            F.Cells(d, 39).Value = WS.Cells(j, 112).Value
            F.Cells(d, 42).Value = WS.Cells(j, 116).Value
        
        End If
        j = j + 1
    Loop
    .Calculation = xlAutomatic
    .ScreenUpdating = True
    End With
End Sub

 

[محمد هشام.]

هل جربت شيء كهدا 

 

If WS.Range("DZ" & j) Like clé or WS.Range("DZ" & j) like "غ" then 

 

تم تعديل يونيو 23 بواسطه محمد هشام.

[2saad]

الله يبارك فيك يا استاذ محمد وجعله الله في ميزان حسناتك

[2saad]

معلش يا استاذ محمد

في التغيير السابق 

لو مفيش دور ثان ولكن فيه ( غ ) تأتي رسالة ( دور ثان غير موجود )

فكيف يتم ترحيل ( غ )

[محمد هشام.]

ارفق ملفك اخي سعد لو سمحت 

[2saad]

معلش استاذي الفاضل التأخير في الرد بسبب الأنترنت

محتاج ترحيل البيانات من CHEET4في الأعمدة الملونة باللون الأصفر 3- 4- 5 - 6 - 7 - 8 - 9 - 10 - 11 - 12 - 13 - 14 -28- 40 - 52 - 64 - 76 - 88 - 100 - 112 - 116- 131  بشرط ( له درو ثان و لها دور ثان و غ )في العمود 131

يتم ترحيلها الي( شيت الدور الثاني صف رابع )

 

الملف المرفق المطلوب

SAAD.xlsm

[2saad]

ارجو المساعدة

 

[محمد هشام.]

هل يتم نسخ البيانات بنفس التنسيق بعد كتابة الكود لاحظت انك واضع تنسيق مخصص على عمود السن في أول أكتوبر 

2) هل يتم افراغ جميع الاعمدة قبل كل ترحيل جديد لان الكود السابق يقوم بافراغ الاعمدة من C  الى O فقط 

  F.Range("C10:O" & Rows.Count).ClearContents

على العموم جرب هدا ووافينا بالنتيجة  

Option Explicit
Public Sub CopyData()
'24/06/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
Dim rCrit() As String, lastRow As Long
Dim Star_Row As Long, Cnt As Long, Cpt As Long
Dim C As Long, Search_Row As Long, tmp As Long
Dim rngA As Variant, rngB As Variant

Dim WS As Worksheet: Set WS = Sheets("cheet4")
Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ")

Cnt = 10
Star_Row = 16
Search_Row = 131
Application.ScreenUpdating = False
rCrit = Split(",لها دور ثان,له دور ثان,غ", ",")

lastRow = WS.Cells(WS.Rows.Count, Search_Row).End(xlUp).Row
    
    rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                 28, 40, 52, 64, 76, 88, 100, 112, 116, 131)
                        
    rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                     15, 18, 21, 24, 27, 30, 33, 36, 39, 42)

   
srcWS.Range("C10:O" & srcWS.Rows.Count).ClearContents
For C = Star_Row To lastRow
  For Cpt = 0 To UBound(rCrit)
   If WS.Cells(C, _
         Search_Row).Value = rCrit(Cpt) Then
For tmp = 0 To UBound(rngA)
    
    srcWS.Cells(Cnt, rngB(tmp)).Value = WS.Cells(C, rngA(tmp)).Value
           Next tmp
        Cnt = Cnt + 1
      End If
   Next Cpt
Next C
Application.ScreenUpdating = True
 MsgBox "Done", vbInformation
End Sub

 

تم تعديل يونيو 24 بواسطه محمد هشام.

[2saad]

شكرا استاذ محمد علي مجهودك

الكود اللي حضرتك وضعته بيرحل ( غ ) فقط

بس أنا عندي شك في وضغ الجزئية دي

لما نقلت الكود كتبت عندي بالشكل السابق

ولكن في كود حضرتك مكتوب  ( لاحظ الفواصل )

rCrit = Split(",لها دور ثان,له دور ثان,غ", ",")

 

[2saad]

استاذ محمد الجزئية ظهرت عندي بالشكل ده

[محمد هشام.]

6 ساعات مضت, 2saad said:

لما نقلت الكود كتبت عندي بالشكل السابق

ولكن في كود حضرتك مكتوب  ( لاحظ الفواصل )

أستاد سعد الكود المقترح يقوم بترحيل الصفوف التي قيمتها  = له دور ثان / لها دور ثان / غ 

كما جاء في آخر مشاركة لك هدا ما فهمت من العبارة التالية.................. بشرط ( له درو ثان و لها دور ثان و غ )في العمود 131 والملف المرفق لا يتضمن نفس الشروط

(طريقة الكتابة مختلفة )  بمعنى الكود لا يتعرف على عبارة {له دور ثان في}

المرجوا محاولة توضيح طلبك  أكثر  في المرة المقبلة لانه من الصعب  مراجعة وتتبع  جميع الصفوف للتحقق من تطابق طريقة كتابة كل قيمة على حدى 

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

Option Explicit
Public Sub CopyData()
'25/06/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
Dim arr As Long, rCrit() As String, lastRow As Long
Dim Star_Row As Long, Cnt As Long, Cpt As Long
Dim C As Long, Search_Row As Long, tmp As Long
Dim rngA As Variant, rngB As Variant, j As String
 
Dim WS As Worksheet: Set WS = Sheets("cheet4")
Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ")

Cnt = 10: Star_Row = 16:   Search_Row = 131
rCrit = Split("دور ثان,غ", ",")

lastRow = WS.Cells(WS.Rows.Count, Search_Row).End(xlUp).Row
 
    rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                 28, 40, 52, 64, 76, 88, 100, 112, 116, Search_Row)
                        
    rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                     15, 18, 21, 24, 27, 30, 33, 36, 39, 42)
    
    arr = Application.Sum _
        (Application.IfError(Application.Match("*" & rCrit(Cpt) & "*", _
                              WS.Columns(Search_Row), 0), 0))
                   If arr = 0 Then: MsgBox " المرجوا التحقق من صحة المعايير ", _
                                                 vbCritical, "انتباه": Exit Sub
Application.ScreenUpdating = False
srcWS.Range("C10:O" & srcWS.Rows.Count).ClearContents
 For C = Star_Row To lastRow
  For Cpt = 0 To UBound(rCrit)
   If WS.Cells(C, _
         Search_Row).Value = rCrit(Cpt) Or WS.Cells(C, _
         Search_Row).Value Like "*" & rCrit(Cpt) & "*" Then
For tmp = 0 To UBound(rngA)
    srcWS.Cells(Cnt, rngB(tmp)).Value = WS.Cells(C, rngA(tmp)).Value
           Next tmp
        Cnt = Cnt + 1
      End If
   Next Cpt
Next C
    Application.ScreenUpdating = True
    MsgBox "Done", vbInformation
End Sub

 

في حالة الرغبة بنسخ البيانات بنفس التنسيق ابلغني بدالك 

SAAD V2.xlsm

تم تعديل يونيو 25 بواسطه محمد هشام.

[2saad]

شكرا استاذ محمد تعبتك معاي

مش عايز يظبط معاي

 

الجزئية بتظهر معاي في الكود بالشكل ده

انظر الي الفاصلة بعد ( غ ) 

هل هي السبب في عدم عمل الكود ؟

[محمد هشام.]

اعتقد انه هناك سوء تفاهم  ما هي النتيجة المتوقعة على اخر عمود رقم 42

انظر الصورة 

[محمد هشام.]

26 دقائق مضت, 2saad said:

هل هي السبب في عدم عمل الكود ؟

لا اخي ليس لها علاقة الملف يشتغل معي بشكل جيد جدا وبدون ادنى مشكلة 

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

[محمد هشام.]

الكود بطريقة اخرى مع الشرح لتتمكن من تعديله بما يناسبك 

Public Sub CopyData2()
    Dim rCrit() As String: ReDim rCrit(1 To 2): Const SrcRow = "EA"
    Dim x&, i&, Cnt&, arr&, lr&, lastRow&, Cpt As Long
    Dim Search_Row As Long, Star_Row As Long, Col As Range
    Dim rngA As Variant, rngB As Variant, OneRng As Range
    Dim WS As Worksheet: Set WS = Sheets("cheet4")
    Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ")
   
 ' تحديد صف البداية
    Star_Row = 16:
   
' عمود الفلترة
     Search_Row = 131
     
 'تحديد صف وضع البيانات المرحلة
    Cnt = 10
    
    
With Application
 .ScreenUpdating = False
 .Calculation = xlManual
 
 lastRow = WS.Range(SrcRow & WS.Rows.Count).End(xlUp).Row
 
 lr = srcWS.Columns("C:AP").Find(What:="*", _
             SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
             
 'معايير الفلترة
rCrit(1) = "غ": rCrit(2) = "*" & "دور ثان" & "*"
'الاعمدة المرحلة
rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                 28, 40, 52, 64, 76, 88, 100, 112, 116, Search_Row)
 'الاعمدة المرحل اليها
rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _
                     15, 18, 21, 24, 27, 30, 33, 36, 39, 42)
'("EA")'التحقق من وجود المعايير على عمود 
arr = Application.Sum _
        (Application.IfError(Application.Match(rCrit, WS.Columns(Search_Row), 0), 0))
        If arr = 0 Then: MsgBox " المرجوا التحقق من صحة المعايير ", _
                                     vbCritical, "انتباه": Exit Sub
   'افراغ البيانات السابقة
For x = 0 To UBound(rngB)
    Set Col = srcWS.Range(srcWS.Cells(Cnt, rngB(x)), srcWS.Cells(lr, rngB(x)))
      Col.ClearContents
       Next x
With WS
    If .AutoFilterMode Then .AutoFilterMode = False
 ' تحديد نطاق البيانات
 With WS.Range("C15:EA15")
    .AutoFilter Search_Row - 2, rCrit, xlFilterValues
 ' نسخ الاعمدة المرئية
 For i = 0 To UBound(rngA)
    Set OneRng = WS.Range(WS.Cells(Star_Row, _
     rngA(i)), WS.Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible)
     
    OneRng.Copy
    'لصق البيانات
     srcWS.Cells(Cnt, rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Next i
      .AutoFilter
    End With
End With

  .CutCopyMode = False
 .Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

 

SAAD V3.xlsm

تم تعديل يونيو 25 بواسطه محمد هشام.

[2saad]

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

الله يبارك فيك دنيا وآخرة وجعله في ميزان حسناتك ويعطيك الصحة والعافية

أنا درست الكود كويس وجدت حاجة بسيطة غيرتها واشتغل ممتاز

غيرت وضع search_row

 

[محمد هشام.]

العفو أخي سعد يسعدنا أننا إستطعنا مساعدتك

بالتوفيق.