طلب دعم في ترحيل البيانات بين ورقتين في ملف Excel

[الو11111في]

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

إلى أعضاء منتديات أوفيسنا الكرام،

أسعد الله أوقاتكم بكل خير،

أود في البداية أن أتقدم إليكم بجزيل الشكر والتقدير على كل ما تقدمونه من دعم ومساعدة، فأنتم بعد الله العون والسند في حل المشكلات التي تواجهنا، وأسأل الله أن يجعل جهودكم في ميزان حسناتكم.

لدي طلب وأحتاج إلى دعمكم الكريم كما عهدناكم دائمًا، حيث يحتوي الملف المرفق على ورقتين، وأرغب في ترحيل البيانات من "ورقة1" إلى "ورقة النموذج النهائي" وفقًا للوصف الموضح داخل الملف.

آمل منكم الدعم، وأسأل الله أن يجزيكم خير الجزاء.

تحياتي وتقديري.

 

طلب ترحيل.xls

[محمد هشام.]

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

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim a() As Variant, ColArr As Variant, CelArr As Variant, txt As String, i As Integer, OnRng As Range
    Dim WS As Worksheet: Set WS = Sheets("النموذج النهائي")
    Set OnRng = Me.Range("A" & Target.Row & ":AC" & Target.Row)
    txt = "مؤقت لمدة"

    If Not Intersect(Target, Me.Range("AD:AD")) Is Nothing And Me.Cells(Target.Row, "AD").Value <> "" Then
        If InStr(Me.Cells(Target.Row, "AD").Value, "ترحيل") > 0 Then
         If Application.CountA(OnRng) = 0 Then: MsgBox "لا يوجد بيانات في الصف ", vbExclamation: Exit Sub
            
            ColArr = Array("i", "G", "d", "C", "O", "U", "F", "Z")
            CelArr = Array("L2", "C9", "E13", "G13", "C14", "C15", "C16", "J26")
            
            ReDim a(LBound(ColArr) To UBound(ColArr))
            For i = LBound(ColArr) To UBound(ColArr): a(i) = Me.Cells(Target.Row, ColArr(i)).Value: Next i
            
            WS.[C21].Value = IIf(Me.Cells(Target.Row, "Q").Value <> "", txt & " (" & Me.Cells(Target.Row, "Q").Value & ") سنوات", "")
            WS.[C22].Value = IIf(IsDate(Me.Cells(Target.Row, "R").Value), Format(Me.Cells(Target.Row, "R").Value, "yyyy/mm/dd"), "")
            WS.[C23].Value = IIf(IsDate(Me.Cells(Target.Row, "S").Value), Format(Me.Cells(Target.Row, "S").Value, "yyyy/mm/dd"), "")
            
            Application.ScreenUpdating = False : Application.EnableEvents = False
            
            On Error GoTo SubApp
            For i = LBound(CelArr) To UBound(CelArr): WS.Range(CelArr(i)).Value = a(i): Next i
            
SubApp:
            Application.ScreenUpdating = True: Application.EnableEvents = True
        End If
    End If
End Sub

 

طلب ترحيل.xls

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

[الو11111في]

ربي يسعد ايامك  مهندس محمد  ،  والف الف شكر على جهودك ودعمك الدائم والمستمر .
لكن  يبدو ان الملف لايعمل لدي  بشكل سليم 
هل هناك  شيء  يجب  ان اقوم بتعديله   ليعمل الملف ؟ 

 

مع خالص الشكر والتقدير  مهندس

تم تعديل فبراير 9 بواسطه الو11111في