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

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

قام بنشر

الاخوه الافاضل

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

كل عام وانتم جميعا بخير

اريد كود او داله لعمل تسلسل للارقام او الاسماء الموجوده فى العمود B

مع اعطاء الارقام او الاسماء المتشابهه نفس الرقم

كود عمل تسلسل.rar

قام بنشر

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

تقبل الله منا ومنكم الصلاة والصيام والقيام وصالح الأعمال....

أخي الكريم هذا حل كبداية باستعمال المعادلات... في انتظار حلول أخرى من إخوتنا الكرام...

أخوك بن علية

تسلسل.rar

قام بنشر

الاخ بن علية

بارك الله فيك

تسلم ايدك

ولكن ماذا لو اردنا حينما تكون اى خليه موجوده فى العمود b فارغه

تكون ايضا الخليه الموجوده فى العمود a المقابله لها فارغه ايضا

قام بنشر


=IF(B3="";"";IF(COUNTIF($B$3:B3;B3)>1;INDEX($A$2:A2;MATCH(B3;$B$2:B2;0));MAX($A$2:A2)+1))

أخى الفاضل / إبراهيم ابوليله

تفضل وكل عام وانتم بخير

قام بنشر

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

تقبل الله منا ومنكم الصلاة والصيام والقيام وصالح العمال....

أخي الكريم، تم تحضير كود بسيط (تحويل المعادلة المقترحة في الملف السابق إلى كود) يقوم بالعملية المطلوبة... أرجو أن يكون مقبولا أو انتظر من الأعضاء الكرام الذين لهم باع كبير في VBA حتى يدلوا بما فضل الله عليكم من علم ويقدموا أكوادا أفضل من الذي وضعته في الملف المرفق...

أخوك بن علية

تسلسل2.rar

قام بنشر

السلام عليكم

بعد إذن الاستاذ بن عليه

هذا كود بحلقات التكرار


Sub Abu_Ahmed()

Dim cl As Range: T = 3

Set MyRng = Range("B3:B" & Range("B65000").End(xlUp).Row)

Set MyRng1 = Range("A3:A" & Range("B65000").End(xlUp).Row)

MyRng1.Value = ""

For Each cl In MyRng

X = Application.CountIf(Range("B3:B" & T), cl)

If X = 1 Then cl.Offset(0, -1) = Application.Max(MyRng1) + 1

If X > 1 Then

For Each cll In MyRng

If cll = cl Then cl.Offset(0, -1) = cll.Offset(0, -1): Exit For

Next

End If

T = T + 1

Next

Set MyRng = Nothing: Set MyRng1 = Nothing

End Sub

قام بنشر

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

ايضا كود اخر بحلقات تكرارية


Sub AL_KHALEDI()

A = "A"	 'عمود التسلسل

B = "B"	 'عمود البيانات

R = 3	 'البيانات تبدأ من الصف

'=================================================

L = Range(B & 65000).End(xlUp).Row

If L < R Then Exit Sub

Range(Cells(R, A), Cells(L, A)).ClearContents

'=================================================

For i = R To L

If Cells(i, A) = "" And Cells(i, B) <> "" Then

	 N = N + 1

	 For ii = i To L

		 If Cells(ii, B) = Cells(i, B) Then

		 Cells(ii, A) = N

		 End If

	 Next ii

End If

Next i

End Sub

قام بنشر


Private Sub Worksheet_Selectionchange(ByVal Target As Range)

A = "A" 'عمود التسلسل

B = "B" 'عمود البيانات

R = 3 'البيانات تبدأ من الصف

'=================================================

L = Range(B & 65000).End(xlUp).Row

If L < R Then Exit Sub

Range(Cells(R, A), Cells(L, A)).ClearContents

'=================================================

For i = R To L

If Cells(i, A) = "" And Cells(i, B) <> "" Then

		 N = N + 1

		 For ii = i To L

				 If Cells(ii, B) = Cells(i, B) Then

				 Cells(ii, A) = N

				 End If

		 Next ii

End If

Next i

End Sub


===============================================

أحى الفاضل / إبراهيم ابوليله

ضع هذا الكود فى حدث الورقة المختارة

يعمل بدون زر

قام بنشر (معدل)

الاخ عبد الله

الاخ الخالدى

الاخ دغيدى

الاخ بن علية

مشكورين على ردوودكم

ولكن لى طلب بسيط انشاء الله

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

ان يكون من الخليه A4 الى الخليه A20 فقط

بحيث اننى حينما اكتب اى رقم ابتداء من الخليه B21 وما بعدها

لا يعطينى تسلسل فى الخليه A21 وما بعدها

وذلك لاننا سنكون حددنا فى الكود نطاق لعمل التسلسل وهو من A4 الى A20

تم تعديل بواسطه إبراهيم ابوليله
قام بنشر

الاخ بن علية

الاخ عبد الله

الاخ الخالدى

الاخ دغيدى

بارك الله فيكم

وكن لى طلب بسيط انشاء الله

وهو كيفيه تحديد نطاق التسلسل ليشمل خلايا محدده بدلا من عمود بالكامل

بمعنى ان يظهر التسلسل فى الخلايا من A4 الى A20 فقط

قام بنشر

السلام عليكم

بعد إذن الاستاذ بن عليه

هذا كود بحلقات التكرار


Sub Abu_Ahmed()

Dim cl As Range: T = 3

Set MyRng = Range("B3:B" & Range("B65000").End(xlUp).Row)

Set MyRng1 = Range("A3:A" & Range("B65000").End(xlUp).Row)

MyRng1.Value = ""

For Each cl In MyRng

X = Application.CountIf(Range("B3:B" & T), cl)

If X = 1 Then cl.Offset(0, -1) = Application.Max(MyRng1) + 1

If X > 1 Then

For Each cll In MyRng

If cll = cl Then cl.Offset(0, -1) = cll.Offset(0, -1): Exit For

Next

End If

T = T + 1

Next

Set MyRng = Nothing: Set MyRng1 = Nothing

End Sub

مجهود رائع جزاك الله عليه خيراً كثيرا..

قام بنشر (معدل)

السلام عليكم

جرب الكود في حدث الورقة


Private Sub Worksheet_Selectionchange(ByVal Target As Range)

Set Rn1 = [A4:A20]

Set Rn2 = Rn1.Offset(0, 1)

Rn1.ClearContents

For i = 1 To Rn1.Rows.Count

   If Rn1(i) = "" And Rn2(i) <> "" Then

	  N = N + 1

	  For ii = i To Rn1.Rows.Count

		 If Rn2(ii) = Rn2(i) Then Rn1(ii) = N

	  Next ii

   End If

Next i

Set Rn1 = Nothing: Set Rn2 = Nothing

End Sub

تم تعديل بواسطه الخالدي

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • اضف...

Important Information