الو11111في قام بنشر فبراير 5 قام بنشر فبراير 5 السلام عليكم ورحمة الله وبركاته، إلى أعضاء منتديات أوفيسنا الكرام، أسعد الله أوقاتكم بكل خير، أود في البداية أن أتقدم إليكم بجزيل الشكر والتقدير على كل ما تقدمونه من دعم ومساعدة، فأنتم بعد الله العون والسند في حل المشكلات التي تواجهنا، وأسأل الله أن يجعل جهودكم في ميزان حسناتكم. لدي طلب وأحتاج إلى دعمكم الكريم كما عهدناكم دائمًا، حيث يحتوي الملف المرفق على ورقتين، وأرغب في ترحيل البيانات من "ورقة1" إلى "ورقة النموذج النهائي" وفقًا للوصف الموضح داخل الملف. آمل منكم الدعم، وأسأل الله أن يجزيكم خير الجزاء. تحياتي وتقديري. طلب ترحيل.xls
تمت الإجابة محمد هشام. قام بنشر فبراير 5 تمت الإجابة قام بنشر فبراير 5 (معدل) وعليكم السلام ورحمة الله تعالى وبركاته 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 بواسطه محمد هشام. 4
الو11111في قام بنشر فبراير 9 الكاتب قام بنشر فبراير 9 (معدل) ربي يسعد ايامك مهندس محمد ، والف الف شكر على جهودك ودعمك الدائم والمستمر . لكن يبدو ان الملف لايعمل لدي بشكل سليم هل هناك شيء يجب ان اقوم بتعديله ليعمل الملف ؟ مع خالص الشكر والتقدير مهندس تم تعديل فبراير 9 بواسطه الو11111في
الردود الموصى بها
انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد
يجب ان تكون عضوا لدينا لتتمكن من التعليق
انشئ حساب جديد
سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .
سجل حساب جديدتسجيل دخول
هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.
سجل دخولك الان