جمع خليتين عن طريق الكود بشرط

[skyblue]

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

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

ارجوا المساعدة في الملف المرفق

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

[الـعيدروس]

السلام عليكم

جرب هذا الكود

Public Sub ali()

For T = 7 To Range("D15000").End(xlUp).Row

If Range("E2").Value > Empty Then

Cells(T, 6) = Range("E2") & " - " & Range("D" & T)

Else

Cells(T, 6) = Empty

End If

Next T

End Sub

[skyblue]

استاذي العيدروس المعذرة  مطلوبي كان خطأ حيث عكست السؤال

وطلبي بعد التصحيح  حسب المرفق  وسامحني على اني اتعبتك

وربي يحفظك

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

[الـعيدروس]

جرب هكذا

Public Sub ali()

For T = 7 To [D1500].End(xlUp).Row

If Cells(T, 4).Value > "" Then

Cells(T, 4) = Range("E2").Value & " _ " & Cells(T, 4).Value

End If

Next T

End Sub

[skyblue]

هناك مشكلة في الكود وهي كلما عملنا كليك يزيد التاريخ

[الـعيدروس]

السلام عليكم

اطلع على المرفق

للعلم تم الاستعانه بعمود إضافي

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

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

السلام عليكم

بعد إذن الاخ ابونصار (ما شاء الله عليه نشاط واضح)

Sub Abu_Ahmed_Tjme3()

Dim cl As Range

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

If Len(cl.Value) > 12 Then GoTo 0

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

0 Next

End Sub

بدون الحاجة الى كود إضافي

شاهد المرفق

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

[skyblue]

اولا شكرا جزيلا لااستاذنا ابو نصار اليوم تعبته معي وشكرا على صبره والاكواد كلها جميلة وادت الغرض .بكفاءة .

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

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

الله يوفقكم وينير لكم طريقكم .

[skyblue]

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

مرفق ملف به الحالة

تحياتي للجميع

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

[الـعيدروس]

السلام عليكم

بيكون هكذا

Sub Abu_Ahmed_Tjme3()

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) < 8 Then GoTo 0

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

0 Next

End Sub

[skyblue]

الكود لايتعامل مع الجملة التي تكون اكبر من 8 . فمثلا الجملة ( زيادة في رصيد البنك شهر ) هذه الجملة لايتعامل معها الكود على الرغم ان عدد حروفها تجاوز 16 حرف

الكود يتعامل فقط مع الجملة اذا كانت 7 فاقل او اذا كانت الجملة 8 فقط .

حسب المرفق

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

[skyblue]

up

[الـعيدروس]

السلام عليكم

جرب هكذا

إن شاء الله يزبط معاك

Public Sub ALI_F()

Dim F_ALI, R_ALI As Range, T As Integer

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

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

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