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

[فضل حسين]

الى خبراء واعضاء منتداى العزيز والعظيم

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

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

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

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

[أبو محمد أشرف]

رجاء التوضيح أكثر 

بخصوص الأرقام المكتوبة باللون الأحمر في ورقة 2 في الصف الأول

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

السلام عليكم

 

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

 

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

[جمال عبد السميع]

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

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

تم تعديل مارس 3, 2013 بواسطه mahmoud-lee

[أبو محمد أشرف]

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

دوما رائع mahmoud-lee

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

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

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

تم تعديل مارس 4, 2013 بواسطه أبو محمد أشرف

[ابراهيم البقري]

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

[فضل حسين]

عاشق الاكسل

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

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

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

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

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

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

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

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

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

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

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

[فضل حسين]

عاشق الاكسل

 

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

 

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

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

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

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

تم تعديل مارس 4, 2013 بواسطه فضل 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

تم تعديل مارس 5, 2013 بواسطه فضل 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

[فضل حسين]

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

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

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

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

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

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

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

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

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

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

وشكرا

تم تعديل مارس 5, 2013 بواسطه فضل 1