تعديل كود للترحيل لملف خارجي ... الي شيت في نفس الملف

[جلال محمد]

اريد من حضاراتكم التعديل علي الكود المرفق 

بدل الترحيل لملف خارجي 

الترحيل لشيت في نفس الملف وليكن اسم الشيت ( Sheets3)

فما التعديل المناسب .... وشكرأ لكم

 

Sub dahmour()
Dim w1, w2 As Workbook
Dim L As String
Set w1 = ActiveWorkbook
Set w2 = Workbooks("STEM  Grade 10.xlsm")
L = w1.Sheets("Sheet2").[d2]
If L <> "" Then
r1 = w1.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
r2 = w2.Sheets("Total").Cells(Rows.Count, 1).End(xlUp).Row
c = w2.Sheets("Total").Range("K13:KJ13").Find(L, LookAt:=xlWhole).Column
For Each cell In w1.Sheets("Sheet2").Range("a11:a" & r1)
For Each cell2 In w2.Sheets("Total").Range("H14:H" & r2)
If cell2.Value = cell.Value Then
w2.Sheets("Total").Cells(cell2.Row, c) = w1.Sheets("Sheet2").Cells(cell.Row, [k4]).Value
Exit For
End If
Next
Next
End If
End Sub

 

[عبدالله بشير عبدالله]

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

يتم التعديل في المتغيرات

1. إزالة المتغير w2 لأننا لن نستخدم ملف خارجي

2. تغيير جميع الإشارات من w2.Sheets("Total") إلى w.Sheets("Sheets3") للعمل مع الشيت المطلوب في نفس الملف

3. اسم الشيت المرحل اليه Sheets3

Sub dahmour() 
    Dim w As Workbook
    Dim L As String
    Dim r1 As Long, r2 As Long, c As Long
    Dim cell As Range, cell2 As Range
    
    Set w = ActiveWorkbook
    L = w.Sheets("Sheet2").[d2].Value
    
    If L <> "" Then
        r1 = w.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
        r2 = w.Sheets("Sheets3").Cells(Rows.Count, 1).End(xlUp).Row
        c = w.Sheets("Sheets3").Range("K13:KJ13").Find(L, LookAt:=xlWhole).Column
        
        For Each cell In w.Sheets("Sheet2").Range("a11:a" & r1)
            For Each cell2 In w.Sheets("Sheets3").Range("H14:H" & r2)
                If cell2.Value = cell.Value Then
                    w.Sheets("Sheets3").Cells(cell2.Row, c) = w.Sheets("Sheet2").Cells(cell.Row, [k4]).Value
                    Exit For
                End If
            Next cell2
        Next cell
    End If
End Sub