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

كود يقوم بترحيل الغياب (غ) (تم تعديل العنوان)


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

السلام عليكم

 

استخدم الكود التالي:


 

Sub kh_Start()
Dim Cel As Range
Dim r As Integer, rr As Integer
For Each Cel In Range("C6:C12")
    rr = Val(Cel)
    If rr Then
        With ورقة2.Range("A2").Cells(rr, Columns.Count).End(xlToLeft)
            .Offset(0, 1).Value = Cel.Offset(0, 2).Value
        End With
    End If
Next
End Sub

 

في امان الله

رابط هذا التعليق
شارك

الأخ الفاضل

عبد الله باقشير

تحية طيبة وبعد

 

تم تطبيق الكود لكن لم يتم تنفيذ المطلوب ياريت ترفق ملف به الكود

وجزاك الله خيرا

 

تفضل المرفق 2003

 

كود زر ترحيل.rar

  • Like 1
رابط هذا التعليق
شارك

بعد إذن أستاذى وعالمى الجليل ( عبد الله بقشير ) هذا حل أخر بالمعادلات

كود زر ترحيل.rar

تم تعديل بواسطه mahmoud-lee
رابط هذا التعليق
شارك

شكرا لك أستاذ خبور

دوما رائع mahmoud-lee

وهذه مشاركة متواضعة مني لا أدري إن كانت صحيحة أم لا ولكن لعلها تفيد وهذا بعد إذن العلامة خبور الخير والاستاذ محمود لي

وارجو التقييم من قبلكم حتى أتعلم

ترحيل أبو محمد.rar

تم تعديل بواسطه أبو محمد أشرف
رابط هذا التعليق
شارك

عاشق الاكسل

العالم الجليل / عبدالله بقشير

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

اولا اسمح لى ان اعرب ان اسفى لتأخرى على الرد ولكن بسبب ظروف خارجة عن ارادتى بسبب مشاكل فى النت .

واسمح لى ان اعرب عن سعادتى وامتنانى وشكرى لمشاركتك وكودك العظيم والجميل مثلك .

فهذا هو المطلوب  بالضبط ياعاشق الاكسل وسبحان الله وكأنك تعرف ماأريد بالضبط . مش عارف اقولك لسيادتكم ايه ولااجد كلمات تعبر عن شكرى وامتنانى لشخصكم الكريم .

ولكن كل مافى وسعى ان ادعو لسيادتكم بدوام الصحة والعافية والتوفيق وان تكون هذة الاعمال فى ميزان حسناتكم يوم القيامة اللهم امين .

استاذى الفاضل /محمود لى

كل الشكر والتقدير لسيادتكم فلكم منى جزيل الشكر على الحل بالمعادلات . وان كنت احب ان اوضح شئى اننى طلبت الحل بالكود لاننى سوف اكتب حرف ( غ ) كثيرا ثم ارحل مرات كثيرة وهكذا وليس مره واحدة

ولكن ياحبيبى امتعتنى بمعادلتك الرائعة مثلك . فكل الحب والتقدير لمجهوداتكم الكريمة

الاستاذ الفاضل / محمد ابو شرف

سعيد جدا بمشاركتك وجزاك الله كل خير .

رابط هذا التعليق
شارك

عاشق الاكسل


 

العالم الجليل / عبدالله بقشير


 

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

مرفق الملف موضح به المطلوب الجديد

واسف  لتاخرى فى ارفاق الملف

كود زر ترحيل.rar

تم تعديل بواسطه فضل 1
رابط هذا التعليق
شارك

السلام عليكم

جزاك الله خيرا

 

بالنسبة للطلب:

هذا الكود:


 

Sub kh_Start()
Dim Cel As Range
Dim Adr As String
Dim r As Integer, rr As Integer

Adr = [J3]

For Each Cel In Range("C6:C12")
    rr = Val(Cel)
    If rr Then
        With ورقة2.Range(Adr).Cells(rr, Columns.Count).End(xlToLeft)
            .Offset(0, 1).Value = Cel.Offset(0, 2).Value
        End With
    End If
Next
MsgBox "تم الترحيل بنجاح"
End Sub

 

المرفق 2003

كود زر ترحيل1.rar

رابط هذا التعليق
شارك

عاشق الاكسل

عالمنا الجليل / عبدالله بقشير

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

ارجو ألا اكون اثقلت عليك بكثرة اسئلتى ياعالمنا الجليل . ولكن ارجو ان تعذرنى فأنا مستمتع جدا وأعيش فى حالة من الجمال والفرحة بأعمالك . .وليس من السهل لطالب علم مثلى ان يترك بسهولة هذا الجمال والامتاع مع عالم جليل مثلك  .  واوعدك باننى سوف ابذل قصارى جهدى بألا اثقل على سيادتكم بكثرة اسئلتى . ولكن علمى بسعة صدركم ونبل اخلاقكم وعطاء سيادتكم هو الذى شجعنى ويشجعنى بأن اطلب المساعدة من كريم شخصكم .

مرفق الملف وموضح به المطلوب الجديد

وانا كلى شوق ولهفة فى انتظار مزيد من الابداع والاستمتاع والجمال مع اكواد عاشق الاكسل

عالمنا الجليل / عبدالله بقشير

والف مليون شكر

كود زر ترحيل111.rar

تم تعديل بواسطه فضل 1
رابط هذا التعليق
شارك

السلام عليكم 

 

هذا تعديل لكود الاستاذ عبدالله باقشير

ub kh_Start()
Dim Cel As Range
Dim Adr As String
Dim r As Integer, rr As Integer
MyDay = Val([B3])
Select Case [C3].Value
    Case Is = "سبتمبر"
     MyMonth = 0
Case Is = "اكتوبر"
     MyMonth = 12
Case Is = "نوفمبر"
     MyMonth = 24
End Select
Adr = [J3]
For Each Cel In Range("C6:C12")
    rr = Val(Cel)
    If rr Then
        With ورقة2.Range(Adr).Cells(rr, MyDay + MyMonth + 1)
            .Offset(0, 1).Value = Cel.Offset(0, 2).Value
        End With
    End If
Next
MsgBox "تم الترحيل بنجاح"
End Sub

رابط هذا التعليق
شارك

السلام عليكم

 

الشكر واصل لاخي الحبيب عبدالله

واتمنى ان يكون هذا آخر طلب

 

انا عدلت في المعادلة بداخل الشيت

في الخلية J3

 

=ADDRESS(VLOOKUP(D3;N2:O5;2;0);((MATCH(C3;R2:R4;0)-1)*12)+B3+2)
 

 

مع تعديل بسيط للكود

Sub kh_Start()
Dim Cel As Range
Dim Adr As String
Dim r As Integer, rr As Integer

Adr = [J3]
For Each Cel In Range("C6:C12")
    rr = Val(Cel)
    If rr Then
        With ورقة2.Range(Adr).Cells(rr, 1)
            .Value = Cel.Offset(0, 2).Value
        End With
    End If
Next
MsgBox "تم الترحيل بنجاح"
End Sub

 

في امان الله

كود زر ترحيل111.rar

رابط هذا التعليق
شارك

عالمنا الجليل

عبدالله بقشير

حل رائع  كالعادة . جزاك الله كل خير وبارك فيك .وزادك الله من علمه وفضله اللهم امين

أنا اسف جدا لاننى اثقلت على سيادتكم بالاسئلة . وارجو تقبل اسفى وعذرى

كل الشكر والتقدير والحب لسيادتكم  مع تمنياتى لكم بالتوفيق ودوام الصحة ومزيد من العلم والتقدم .

وللمرة الثانية بالله عليك سامحنى ان كنت اثقلت عليك واوعدك اننى لن اثقل عليك مره اخرى ولن يتكرر هذا مرة اخرى

استاذى الفاضل / المايسترو

والله زمان ياحبيبى . وحشتنا ووحشتنا ابداعاتك  واعمالك الجميلة

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

والف مليون شكر

وشكرا

تم تعديل بواسطه فضل 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information