عمل عداد برجاء الافادة ان امكن

[حسام فوزى]

برجاء ان امكن عمل العداد كما فى المثال

وشكرا 

 

عداد.rar

[ياسر خليل أبو البراء]

السلام عليكم (مفيش لا سلام .. ولا حتى كلام ::  يا قلبك القاسي يا حوسو)

بص يا سيدي جرب الكود التالي في حدث ورقة العمل (لو مش فاهم كلامي : اعمل كليك يمين على اسم ورقة العمل اللي هي Sheet1 .. مفيش غيرها عندك في الملف بتدور على ايه؟)

عملت كليك يمين .. هتلاقي قايمة فيها أوامر اختار منها View Code .. وانسخ الكود اللي في المشاركة والصقه هناك وهو دا حدث ورقة العمل عشان متوهشي مني !!

وآدي الكود عشان خاطر عيونك السود

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    
    If Target.Address = "$A$2" Then
        Dim c As Range
        
        Range("B3").Value = Target.Value
        
        For Each c In Range("C3:Z3")
            If c.Offset(, -1) = 1 Then
                c.Value = 2
            ElseIf c.Offset(, -1) = 2 Then
                c.Value = 3
            ElseIf c.Offset(, -1) = 3 Then
                c.Value = 1
            End If
        Next c
    End If
End Sub

 

[سليم حاصبيا]

بعد اذن اخي ابو البراء

معادلة بسيطة في الخلية C3 و تسحب ياسراً

=IF(B3<3,B3+1,1)

 

4 ساعات مضت, ياسر خليل أبو البراء said:

السلام عليكم (مفيش لا سلام .. ولا حتى كلام ::  يا قلبك القاسي يا حوسو)

بص يا سيدي جرب الكود التالي في حدث ورقة العمل (لو مش فاهم كلامي : اعمل كليك يمين على اسم ورقة العمل اللي هي Sheet1 .. مفيش غيرها عندك في الملف بتدور على ايه؟)

عملت كليك يمين .. هتلاقي قايمة فيها أوامر اختار منها View Code .. وانسخ الكود اللي في المشاركة والصقه هناك وهو دا حدث ورقة العمل عشان متوهشي مني !!

وآدي الكود عشان خاطر عيونك السود

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    
    If Target.Address = "$A$2" Then
        Dim c As Range
        
        Range("B3").Value = Target.Value
        
        For Each c In Range("C3:Z3")
            If c.Offset(, -1) = 1 Then
                c.Value = 2
            ElseIf c.Offset(, -1) = 2 Then
                c.Value = 3
            ElseIf c.Offset(, -1) = 3 Then
                c.Value = 1
            End If
        Next c
    End If
End Sub

 

اخي ياسر ما فيش لزوم لكل هذا التعب في وضع هكذا كود

يكقي معادلة بسيطة

=IF(B3<3,B3+1,1)

 

[ابوعبدالواجد]

=IF($B$3<3;B3+1;1)

بعد تثبيت النطاق

 

[ياسر خليل أبو البراء]

كود آخر أبسط بدلاً من استخدام الحلقات التكرارية

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub

    If Target.Address = "$A$2" Then
        Dim c As Range

        Range("B3").Value = Target.Value
        With Range("C3:Z3")
            .Formula = "=MOD(B3,3)+1"
            .Value = .Value
        End With
    End If
End Sub

 

[سليم حاصبيا]

29 دقائق مضت, ابوعبدالواجد said:

=IF($B$3<3;B3+1;1)

بعد تثبيت النطاق

 

لا لزوم لتثبيت النطاق

[حسام فوزى]

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

جميعا واسف على التاخير كنت مسافر 

انا حاولت جرب الاكواد ولكن ماشتغلتش معايا

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    
    If Target.Address = "$A$2" Then
        Dim c As Range
        
        Range("B3").Value = Target.Value
        
        For Each c In Range("C3:Z3")
            If c.Offset(, -1) = 1 Then
                c.Value = 2
            ElseIf c.Offset(, -1) = 2 Then
                c.Value = 3
            ElseIf c.Offset(, -1) = 3 Then
                c.Value = 1
            End If
        Next c
    End If
End Sub

 

ولو امكن بدل 1 و 2 و 3

x - ص - م

شكرا 

ياسر خليل أبو البراء

ابوعبدالواجد

سليم حاصبيا

[سليم حاصبيا]

7 دقائق مضت, حسام فوزى said:

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

جميعا واسف على التاخير كنت مسافر 

انا حاولت جرب الاكواد ولكن ماشتغلتش معايا

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    
    If Target.Address = "$A$2" Then
        Dim c As Range
        
        Range("B3").Value = Target.Value
        
        For Each c In Range("C3:Z3")
            If c.Offset(, -1) = 1 Then
                c.Value = 2
            ElseIf c.Offset(, -1) = 2 Then
                c.Value = 3
            ElseIf c.Offset(, -1) = 3 Then
                c.Value = 1
            End If
        Next c
    End If
End Sub

 

ولو امكن بدل 1 و 2 و 3

x - ص - م

شكرا 

ياسر خليل أبو البراء

ابوعبدالواجد

سليم حاصبيا

لم افهم عليك ماذا تعني x - ص - م

[حسام فوزى]

شرح الملف لو انا بادا بادئ ب

1

يبقى 

التالى

2

والتالى 

3 

وهكذا

لحد اخر التحديد z3

بدل ذلك يبقى

لو بدا ب مثلا 

x 

يبقى التالى ص

والتالى 

م

والتالى 

x 

هكذا لكن لابد من بعد ال 

x 

ص

[حسام فوزى]

ودة للمثال الفعلى 

برجاء افادتى وانا اسف على تعبك حضراتكم

شكرا

توضيحى اكثرعداد.rar

بحيث يكون لكل  شيت بداية  حتى يكمل باقى الحروف

[ياسر خليل أبو البراء]

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

عموماً شوف الكود دا .. ضع الكود في حدث ورقة العمل :: هتقولي إزاي؟ هرد أقولك قلت لك قبل كدا ..

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim arr         As Variant
    Dim temp        As Variant
    Dim x           As Variant
    Dim i           As Integer

    If Target.Cells.Count > 1 Then Exit Sub

    If Target.Column = 2 And Target.Row > 2 Then
        Application.EnableEvents = False
            arr = Array("X", "ص", "م")
            ReDim temp(1 To 23)
            x = Application.Match(Target.Value, arr, 0)
    
            If Not IsError(x) Then
                For i = 1 To UBound(temp)
                    temp(i) = arr(x - 1)
                    If x = 3 Then x = 1 Else x = x + 1
                Next i
            End If
            
            Target.Offset(, 1).Resize(, UBound(temp)).Value = temp
        Application.EnableEvents = True
    End If
End Sub

 

[حسام فوزى]

5 hours ago, ياسر خليل أبو البراء said:

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

عموماً شوف الكود دا .. ضع الكود في حدث ورقة العمل :: هتقولي إزاي؟ هرد أقولك قلت لك قبل كدا ..

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim arr         As Variant
    Dim temp        As Variant
    Dim x           As Variant
    Dim i           As Integer

    If Target.Cells.Count > 1 Then Exit Sub

    If Target.Column = 2 And Target.Row > 2 Then
        Application.EnableEvents = False
            arr = Array("X", "ص", "م")
            ReDim temp(1 To 23)
            x = Application.Match(Target.Value, arr, 0)
    
            If Not IsError(x) Then
                For i = 1 To UBound(temp)
                    temp(i) = arr(x - 1)
                    If x = 3 Then x = 1 Else x = x + 1
                Next i
            End If
            
            Target.Offset(, 1).Resize(, UBound(temp)).Value = temp
        Application.EnableEvents = True
    End If
End Sub

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

تسلملى عندى سوال بس رخم لو حبيت اضيف مثلا  

x-ص-م-ع-ض

اضيفها منين

 

[حسام فوزى]

تم الحل 

 

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

حضرتك ماتعرفش فدتنى اد اية ربنا يكرمك

[ياسر خليل أبو البراء]

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

تقبل تحياتي

[سليم حاصبيا]

بعد اذن اخي الحبيب ياسر

نفس الشيء بمعادلة واحدة توضع  في الخلية C3 و تسحب يساراً ثم نزولاُ

=IF($B3="","",IF(COLUMNS($A$1:A1)=1,B3,INDEX({"X";"ص";"م"},IF(MATCH(B3,{"X";"ص";"م"},0)=3,1,MATCH(B3,{"X";"ص";"م"},0)+1))))

الملف مرفق مع المعادلة المطلوبة

 

عداد Salim.rar

[ياسر خليل أبو البراء]

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

[سليم حاصبيا]

   يمكن استعمال هذا الماكرو (الملف مرفق)صفحة salim

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr
Dim x%, n%
Application.EnableEvents = False
On Error Resume Next
If Target.Column = 2 And Target.Row > 2 And Target.Cells.Count = 1 Then
Arr = Array("X", "ص", "م", "ع", "ض")
Application.AddCustomList ListArray:=Arr
x = Application.Match(Target, Arr, 0)
    If x Then
        Target.Offset(0, 1) = Target
        Target.Offset(0, 1).AutoFill Target.Offset(0, 1).Resize(1, 23)
        Else
        MsgBox "Unvaliable Value": Target.Resize(, 24) = ""
    End If
End If
1:
n = Application.GetCustomListNum(Array("X", "ص", "م", "ع", "ض"))
Application.DeleteCustomList n
Application.EnableEvents = True
End Sub

7 ساعات مضت, حسام فوزى said:

 

عداد Salim WithVBA.rar