الكود المرفق يعمل بكفاءة ولكنه يكرر اضافة التاريخ عند عمل كليك

[skyblue]

الاساتذة المشرفين والاعضاء الافاضل

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

في الملف المرفق الكود التالي :

Sub abu_ahmad()

Dim cl As Range

For Each cl In Range("D7:D" & [D1500].End(xlUp).Row)

If Len(cl.Value) < 8 Then GoTo 0

If Len(cl.Value) > 9 Then cl.Value = [E2].Value & " _ " & cl.Value

0  Next

End Sub

هذا الكود يعمل بشكل ممتاز ولكن المشكلة فيه انه عند ما اعمل كليك يقوم بتكراراضافة التاريخ وهكذا ....

فما هي المشكلة في الكود .

تجميع الخلايا في خل0ية واحدة.rar

[الـعيدروس]

السلام عليكم

الاخ الفاضل skyblue

هل جربت الكود الاخير الذي في المشاركة السابقة

والذي هو هذا ولم يزبط معك ام ماذا ؟؟؟

Public Sub ALI_F()

Dim F_ALI, R_ALI As Range, T As Integer

F_ALI = Array("2011", "/", "01", "11", "12", "_", "1")

For T = 0 To 3

For Each R_ALI In Range("D7", Range("D" & Rows.Count).End(xlUp))

If InStr(R_ALI, F_ALI(T)) <> 0 Then

GoTo 1

Exit Sub

Else

If R_ALI.Value <> "" Then R_ALI.Value = [E2].Value & " _ " & R_ALI.Value

End If

1

Next R_ALI

Next T

End Sub

[skyblue]

نعم جربت الكود ولكنه لم يزبط معي . ولكن اللي الكود اللي في المشاركة كان يعالج كل الحالات ولكن من عيوبه التكرار فقط .

[الـعيدروس]

السلام عليكم

طيب حصرنا الشرط موجب الخليه نفسها

جرب هكذا

Public Sub ALI_F()

On Error Resume Next

Application.DisplayAlerts = False

Dim F_ALI, R_ALI As Range, T As Integer

F_ALI = Array(Range("E2"), "/")

For T = 0 To 3

For Each R_ALI In Range("D7", Range("D" & Rows.Count).End(xlUp))

If InStr(R_ALI, F_ALI(T)) <> 0 Then

GoTo 1

Exit Sub

Else

If R_ALI.Value <> "" Then R_ALI.Value = [E2].Value & " _ " & R_ALI.Value

End If

1

Next R_ALI

Next T

Application.DisplayAlerts = True

End Sub

sh1.rar

تم تعديل ديسمبر 20, 2011 بواسطه alidroos

[الحسامي]

السلام عليكم

هنا حل اخر لعله يثري الموضوع وهو تعديل للكود الاصلي :

Sub abu_ahmad()

Dim cl As Range

For Each cl In Range("D7:D" & [D1500].End(xlUp).Row)

If Len(cl.Value) > 9 And IsDate(Left(cl, Len([E2]))) <> True Then _

cl.Value = [E2].Value & " _ " & cl.Value

Next

End Sub

[عبدالله المجرب]

السلام عليكم

ما دام الحسامي تدخل فلا نقاش في الاجابة

سلمت يمينك استاذ عماد على هذه الدرر

[الـعيدروس]

السلام عليكم

بارك الله فيك استاذنا الحسامي

مميز بتفكيرك وصياغة الأكواد

تقبل مروري

[skyblue]

شكرا استاذ عماد الحسامي على الحل الرائع وكما قال احب احمد بعد حل الحسامي مافي نقاش .

الشكر موصول للاساتذة العيدروس الي اثرى الموضوع بعدة حلول وكان متعاونا الى ابعد الحدود والشكر موصول ايضا لاابو احند . فردودكم للاستاذ الحسامي يدل على الموضوع يهمكم ايضا .

هذه للحسامي وهذه للعيروس وهذه لعبدالله المجرب مع دعوة لكم ان شاء الله