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

[جلال محمد]

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

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

الترحيل لشيت في نفس الملف وليكن اسم الشيت ( 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

 

[جلال محمد]

وعليكم السلام ... شكرا استاذ عبد الله 

[جلال محمد]

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, 3).End(xlUp).Row
        r2 = w.Sheets("حصر الغياب").Cells(Rows.Count, 1).End(xlUp).Row
        c = w.Sheets("حصر الغياب").Range("E7:Z7").Find(L, LookAt:=xlWhole).Column
        
        For Each cell In w.Sheets("Sheet2").Range("a11:a" & r1)
            For Each cell2 In w.Sheets("حصر الغياب").Range("D8:D" & r2)
                If cell2.Value = cell.Value Then
                    w.Sheets("حصر الغياب").Cells(cell2.Row, c) = w.Sheets("Sheet2").Cells(cell.Row, [k4]).Value
                    Exit For
                End If
            Next cell2
        Next cell
    End If
End Sub

يوجد خطا في هذ السطر

c = w.Sheets("حصر الغياب").Range("E7:Z7").Find(L, LookAt:=xlWhole).Column

مرفق ملف

غياب.xlsm

تم تعديل منذ 2 ساعات بواسطه جلال محمد