ما هو الخطأ بجزئية المسح بالكود

[2saad]

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

عايز اعرف ايه الخطأ اللي في الكود ده في الجزئية دي بالتحديد (    sh.Range("C10:L1000").ClearContents )

 كلما انفذ الكود عندي يمسح حتي اللي بعد L1000  يعني يمسح M و N  و O.....

وشكرا لكم جميعا

 

 

 Sub استدعاء_كنترول4_الي_ملف_نصف_العام_صف_رابع()
    Dim arr     As Variant
    Dim temp    As Variant
    Dim cr      As Variant
    Dim lr      As Long
    Dim i       As Long
    Dim j       As Long
    Dim C       As Long
    Dim WS As Worksheet
    Dim sh As Worksheet
    Dim myArray, targt, targt2
    
    Set Main = Sheets("كنترول4")
    Set sh = Sheets("ملف وتحريري نصف العام صف رابع")
    
    targt = sh.Range("M5").Value & "*"
    targt2 = sh.Range("M6").Value & "*"
    'targt = "ذك*"
    'targt2 = "نا*"


    '= = = = = = = = = = = =
    ' شيت الهدف والمدى المطلوب مسحه
    sh.Range("C10:L1000").ClearContents
    
        ' عدد الصفوف في ورقة المصدر
    lr = Main.Cells(Rows.Count, 4).End(xlUp).Row
    
            'متغير اسم ورقة المصدرومدى البيانات بها
    arr = Main.Range("A10:R" & lr).Value
    
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
    'ارقام الاعمده المطلوب نقلها
      cr = Array(2, 4, 5, 7, 9, 10, 11, 12, 15)
    j = 1
 
    For i = LBound(arr, 1) To UBound(arr, 1)
    '==================
    'اذا أردت  ان يستدعي بيانات بدون شرط
    'ماعليك الا ان تجعل السطر البرمجي الموجود
    'اسفل هذا السطر لا يعمل
    '==================
               'رقم عمود الذي سيتم البحث فيه
       'If arr(i, 😎 Like targt & "*" _
       And arr(i, 89) Like targt2 & "*" Then


    '==================
            temp(j, 1) = j
            For C = LBound(cr) To UBound(cr)
                temp(j, C + 2) = arr(i, cr(C))
            Next C
            j = j + 1
    '==================
            '==================
    Next i
        With sh
        'خليه بدايه اللصق في شيت الهدف
        .Range("C10").Resize(j - 1, UBound(temp, 2)).Value = temp
        
    End With
End Sub

 

[2saad]

معلش حضرتك لقلة خبرتي ...وهذا لشرح المطلوب

الملف المرفق مكون من ورقتين عمل    saad    و data

وعند الضغط عل زر الترحيل الموجود في الورقة data يتم ترحيل البيانات من الأعمدة المحددة من ورقة العمل  saad  الي ورقة العمل data

المشكلة ان الكود ده يمسح البيانات المرحلة القديمة ويحل محلها الجديدة في النطاق المحدد بالكود   sh.Range("C10:L1000").ClearContents

وكمان يمسح باقي البيانات في الأAHMAD.xlsmعمدة الأخري M و N  و  O 

انا عايزه يمسح النطاق المحدد فقط يعني من C10:L1000 وباقي البيانات الموجودة في الأعمدة M و N  و  O  تكون ثابتة لا تمسح 

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

 تم انشاء كود جديد يلبي المطلوب بادن الله

Sub M_H()
Dim i As Long
Dim MH As Long, k As Long
Application.ScreenUpdating = False
With Sheets("saad")
lr = Cells(Rows.Count, 1).End(3).Row

'افراغ النطاق من البيانات السابقة قبل الترحيل

Sheets("data").Range("c10:l" & lr).ClearContents
lrow = .Cells(Rows.Count, 2).End(xlUp).Row

 ' الاعمدة المطلوب ترحيلها
frt = Split("B,D,E,G,I,L,J,K,O", ",")

 'الاعمدة المرحل اليها
tot = Split("D,E,F,G,H,K,I,J,L", ",")
For i = LBound(frt) To UBound(frt)

 'نسخ البيانات ابتداءا من الصف العاشر
.Range(frt(i) & "10:" & frt(i) & lrow).Copy Sheets("Data").Range(tot(i) & "10")

Next i
    End With
    
    ' ترقيم تلقائي للصفوف المرحلة بشرط وجود قيمة في 
'العمود(D)
'ابتداءا من الصف العاشر

    With Sheets("data")
        k = 1
        For MH = 10 To .Range("D" & .Rows.Count).End(xlUp).Row
            If .Range("C" & MH) = valeu Then
                .Range("C" & MH) = k
                k = k + 1
            End If
        Next MH
    End With

' كود اظافي
'With Sheets("data")
        '.Range("C10") = 1
        '.Range("C11") = 2
        '.Range("C10:C11").AutoFill .Range("C10:C" & lrow)
    'End With

End Sub


    
       

AHMAD-MH.xlsm

[ابوبسمله]

السلام عليكم

مشاركه مع الاخ الفاضل @Mohamed Hicham جزاه الله خيرا 💐 🌹

تم تعديل السطر التالى باضافه ناقص 6 وهى الاعمده الفارغه

 .Range("C10").Resize(j - 1, UBound(temp, 2) - 6).Value = temp

بالتوفيق

AHMAD(1).xlsm

[محمد هشام.]

اقتباس

عفوا لم انتبه للصفوف الفارغة اسفل الشيت  
تم تعديل هذا السطر في الكود
lrow = .Cells(Rows.Count, 5).End(xlUp).Row
تفاديا للفراغات في الاعمدة
C,D,L
عند الترحيل

 

 

AHMAD - MH-2.xlsm

[2saad]

معلش فيه خطأ صغير في هذا الكود ..ارجو تصحيحه ...المطلوب بالمرفق

AHMAD - MH-2.xlsm

[محمد هشام.]

الملف الذي تم إرفاقه في المشاركة فوق ليس به أي مشكلة في الترحيل ربما قد غيرت شيئ ما بدون قصد على العموم قد تم حل المشكلة 

أما بالنسبة للتسطير كان عليك أولا تجرب تسطير ورقة saad وتشوف!!!

تم إرفاق ملفان  واحد بتسطير ورقة saad والثاني باستخدام التنسيق الشرطي .لكي تكتشف الفرق 

AHMED.rar

[2saad]

شكرا علي رد حضرتك

بس أنا وضعت معادلة في الملف المرفق الجديد في في عمود الفصل في ورقة saad

ولما برحل البيانات الي data بيترحل عمود الفصل خطأ

الملف المرفق مرة ثانيةAHMAD - MH-2.xlsm

[محمد هشام.]

Sub copy_columns_MH()
Dim MH As Long, k As Long
Dim lr As Integer, erow As Integer, sh1 As Worksheet, sh2 As Worksheet, i As Long
Set sh1 = Worksheets("saad")
Set sh2 = Worksheets("data")
Application.ScreenUpdating = False
 Range("c10:L10000").ClearContents
lr = sh1.Cells(Rows.Count, 3).End(xlUp).Row
 For i = 11 To lr
     erow = sh2.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row
    sh2.Cells(erow, 4) = sh1.Cells(i, 2)
    sh2.Cells(erow, 5) = sh1.Cells(i, 4)
    sh2.Cells(erow, 6) = sh1.Cells(i, 5)
    sh2.Cells(erow, 7) = sh1.Cells(i, 7)
    sh2.Cells(erow, 8) = sh1.Cells(i, 9)
    sh2.Cells(erow, 9) = sh1.Cells(i, 10)
    sh2.Cells(erow, 10) = sh1.Cells(i, 11)
    sh2.Cells(erow, 11) = sh1.Cells(i, 12)
    sh2.Cells(erow, 12) = sh1.Cells(i, 15)
        Next i
With Sheets("data")
        k = 1
        For MH = 10 To .Range("D" & .Rows.Count).End(xlUp).Row
            If .Range("C" & MH) = valeu Then
                .Range("C" & MH) = k
                k = k + 1
            End If
        Next MH
    End With
    Application.ScreenUpdating = True
End Sub

AHMAD - MH-3.xlsm

[2saad]

شكرا جزيلا وبارك الله فيك