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

[جلال محمد]

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

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

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

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

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

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

الكود المرفق في طلبك الاول لا يتناسب مع وافع الملف  وخصوصا النطاقات K13:KJ  - H14:H فهي ليس لها اهمية خسب ملفك المرفق

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

يتم ما تم ترخيله باللون الاصفر ويمكن الغائها من الكود بحذف السطر  w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153)

الكود 

Sub dahmour()
    Dim w As Workbook
    Dim L As Variant
    Dim r1 As Long, r2 As Long, c As Long
    Dim cell As Range, cell2 As Range
    Dim colNum As Long
    Dim matched As Boolean
    Dim rng As Range, cellDate As Range

    Set w = ActiveWorkbook
    L = w.Sheets("Sheet2").Range("D2").Value

    If L = "" Then
        MsgBox "يرجى اختيار التاريخ من الخلية D2!", vbExclamation
        Exit Sub
    End If

    r1 = w.Sheets("Sheet2").Cells(w.Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row
    r2 = w.Sheets("Galal").Cells(w.Sheets("Galal").Rows.Count, 1).End(xlUp).Row

    Set rng = w.Sheets("Galal").Range("E7:Z7")
    c = 0

    For Each cellDate In rng
        If IsDate(cellDate.Value) And IsDate(L) Then
            If CDate(cellDate.Value) = CDate(L) Then
                c = cellDate.Column
                Exit For
            End If
        End If
    Next cellDate

    If c = 0 Then
        MsgBox "لم يتم العثور على التاريخ '" & L & "' في الصف 7 من ورقة Galal", vbCritical
        Exit Sub
    End If

    If IsNumeric(w.Sheets("Sheet2").Range("K4").Value) Then
        colNum = w.Sheets("Sheet2").Range("K4").Value
    Else
        MsgBox "الخانة K4 يجب أن تحتوي على رقم العمود المراد ترحيله!", vbExclamation
        Exit Sub
    End If

    matched = False

    For Each cell In w.Sheets("Sheet2").Range("A11:A" & r1)
        If Trim(cell.Value) <> "" Then
            For Each cell2 In w.Sheets("Galal").Range("A8:A" & r2)
                If Trim(cell.Value) = Trim(cell2.Value) Then
                    w.Sheets("Galal").Cells(cell2.Row, c).Value = w.Sheets("Sheet2").Cells(cell.Row, colNum).Value
                    w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153)
                    matched = True
                    Exit For
                End If
            Next cell2
        End If
    Next cell

    If matched Then
        MsgBox "تم الترحيل بنجاح!", vbInformation
    Else
        MsgBox "لم يتم العثور على أي رقم جلوس مطابق!", vbExclamation
    End If
End Sub

الملف

غياب1.xlsm

 

 

تم تعديل منذ 3 ساعات بواسطه عبدالله بشير عبدالله