اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر

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

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

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

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

لدي طلب وأحتاج إلى دعمكم الكريم كما عهدناكم دائمًا، حيث يحتوي الملف المرفق على ورقتين، وأرغب في ترحيل البيانات من "ورقة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

تم تعديل بواسطه محمد هشام.
  • Like 4
قام بنشر (معدل)

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

 

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

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

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information