طلب تعديل على كود ترحيل بيانات

[محمد عبد الناصر]

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

الكود هذا يقوم باخذ الصف كوبي اذا تحقق شرط كتابة اسم محدد وهو ( دريم ) يقوم بنسخ الصف باكمله وينقله كوبي الى شيت "دريم"

اريد تعديل ان يقوم بنقل الصف من الخليه B الى الخليه G فقطط 

Sub CopyRowsmaktab()
    Dim LR As Long, I As Long, X As Long
    LR = Sheets("Main").Cells(Rows.Count, "B").End(xlUp).Row
    X = 6
    Application.ScreenUpdating = False
        Sheets("دريم").Rows("6:1000").ClearContents

        
        For I = 6 To LR
            If Cells(I, "B").Value = "دريم" Then Rows(I).Copy Sheets("دريم").Range("A" & X): X = X + 1
 
            

        Next I
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[محمد هشام.]

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

يمكنك إختيار ما يناسبك 

 

Sub CopyRowsmaktab()
    Dim LR As Long, I As Long, X As Long
    LR = Sheets("Main").Cells(Rows.Count, "B").End(xlUp).Row
    X = 6
    Application.ScreenUpdating = False
    
    Sheets("دريم").Range("B6:G" & Sheets("دريم").Rows.Count).ClearContents
    
    For I = 6 To LR
        If Sheets("Main").Cells(I, "B").Value = "دريم" Then
            Sheets("دريم").Range("B" & X & ":G" & X).Value = Sheets("Main").Range("B" & I & ":G" & I).Value
            X = X + 1
        End If
    Next I
    
    Application.ScreenUpdating = True
End Sub

 او

Sub CopyRowsToDream()
    Dim WS As Worksheet, dest As Worksheet
    Dim LastRow As Long, n As Long, X As Long
    Dim WSRng As Range, destRng As Range, Criteria As String
    
    Set WS = Sheets("Main")
    Set dest = Sheets("دريم")
    
    Criteria = "دريم"
    
    LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
    
    X = 6
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    dest.Range("B6:G" & dest.Rows.Count).ClearContents
    
    For n = 6 To LastRow
        If WS.Cells(n, "B").Value = Criteria Then
            Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G"))
            Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G"))
            destRng.Value = WSRng.Value
            X = X + 1
        End If
    Next n
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

او 

Sub CopiesToDream()
    Dim WS As Worksheet, dest As Worksheet
    Dim LastRow As Long, n As Long, X As Long
    Dim Ky As Boolean, WSRng As Range, destRng As Range
    
    Set WS = Sheets("Main")
    Set dest = Sheets("دريم")
    
    LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
    X = 6
    Ky = False
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For n = 6 To LastRow
        If WS.Cells(n, "B").Value = "دريم" Then
            Ky = True
            Exit For
        End If
    Next n
    
    If Not Ky Then
        MsgBox "لا يوجد بيانات مطابقة للنسخ", vbExclamation
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        Exit Sub
    End If
    
    dest.Range("B6:G" & dest.Rows.Count).ClearContents
    For n = 6 To LastRow
        If WS.Cells(n, "B").Value = "دريم" Then
            Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G"))
            Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G"))
            destRng.Value = WSRng.Value
            X = X + 1
        End If
    Next n
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "تم نسخ البيانات بنجاح", vbInformation
End Sub

 

تم تعديل ديسمبر 3 بواسطه محمد هشام.

[محمد عبد الناصر]

ماشاء الله بارك الله فيك استاذ محمد هشام