تعديل على كود ترحيل الى جدول بناء على إسم الجدول

[مهند الزيدي]

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

جدول إجور2.rar

[ياسر خليل أبو البراء]

أخي الكريم مهند

جرب الكود بعد التعديل

Sub TarhilData2()
    Dim WS As Worksheet, SH As Worksheet
    Dim X As Long, Y As Long, Cell As Range
    Dim lRow As Long
    
    Set WS = Sheets("البيانات"): Set SH = Sheets("طبيب أطفال")
    
    Application.ScreenUpdating = False
        For Each Cell In WS.Range("X2:X11")
            If Not IsEmpty(Cell) Then
                X = Application.WorksheetFunction.Match(Cell.Value, SH.Rows(1), 0)
                lRow = SH.Cells(49, X).End(xlUp).Row + 1
                
                WS.Range(Cell.Offset(, -22), Cell.Offset(, -20)).Copy
                SH.Cells(lRow, X).PasteSpecial xlPasteValues
                Cell.Offset(, -1).Copy
                SH.Cells(lRow, X + 3).PasteSpecial xlPasteValues
               Cell.Offset(, 3).Copy
                SH.Cells(lRow, X + 4).PasteSpecial xlPasteValues
            End If
        Next Cell
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

 

[مهند الزيدي]

شكرا لك اخي العزيز " ياسر " وفقكم الله لكل خير ورزقكم دوام الصحة والعافية