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

**2saad** · يونيو 23

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

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

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

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

**محمد هشام.** · يونيو 23

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

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

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

**2saad** · يونيو 23

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

**2saad** · يونيو 23

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

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

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

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

**محمد هشام.** · يونيو 23

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

**2saad** · يونيو 24

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

محتاج ترحيل البيانات من 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** · يونيو 24

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

**محمد هشام.** · يونيو 24

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

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** · يونيو 25

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

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

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

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

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

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

**2saad** · يونيو 25

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

**محمد هشام.** · يونيو 25

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

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

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

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

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

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

Capture.PNG.e90d07ec18f361c472b9ef7f9269e10a.PNG

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

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

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** · يونيو 25

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

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

image.png.7b3875a09639b6ae2f9e7c0498321e40.png

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

image.png.82970d76ceadea350a0f6157d718fd01.png

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

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

**محمد هشام.** · يونيو 25

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

انظر الصورة

66.PNG.2f240dc0f3bf558ff06d794d620110c2.PNG

**محمد هشام.** · يونيو 25

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

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

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

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

**محمد هشام.** · يونيو 25

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

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** · يونيو 25

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

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

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

image.png.bbc6687d8f6eec00efa3ddd6c5a9214b.png

غيرت وضع search_row

image.png.80bc806e80586a686835d9168d9e92fe.png

**محمد هشام.** · يونيو 27

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

بالتوفيق.

تسجيل الدخول

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

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

من فضلك سجل دخول لتتمكن من التعليق

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information