الو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في
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.