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

حسام فوزى · يوليو 9, 2017

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

وشكرا

ياسر خليل أبو البراء · يوليو 9, 2017

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

بص يا سيدي جرب الكود التالي في حدث ورقة العمل (لو مش فاهم كلامي : اعمل كليك يمين على اسم ورقة العمل اللي هي 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

**سليم حاصبيا** · يوليو 9, 2017

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

معادلة بسيطة في الخلية 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)

ابوعبدالواجد · يوليو 9, 2017

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

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

ياسر خليل أبو البراء · يوليو 9, 2017

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

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

**سليم حاصبيا** · يوليو 9, 2017

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

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

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

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

حسام فوزى · يوليو 14, 2017

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

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

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

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 - ص - م

شكرا

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

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

سليم حاصبيا

**سليم حاصبيا** · يوليو 14, 2017

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 - ص - م

حسام فوزى · يوليو 14, 2017

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

1

يبقى

التالى

2

والتالى

3

وهكذا

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

بدل ذلك يبقى

لو بدا ب مثلا

x

يبقى التالى ص

والتالى

م

والتالى

x

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

x

ص

حسام فوزى · يوليو 14, 2017

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

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

شكرا

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

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

ياسر خليل أبو البراء · يوليو 14, 2017

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

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

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

حسام فوزى · يوليو 14, 2017

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-ص-م-ع-ض

اضيفها منين

حسام فوزى · يوليو 14, 2017

تم الحل

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

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

ياسر خليل أبو البراء · يوليو 14, 2017

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

تقبل تحياتي

**سليم حاصبيا** · يوليو 14, 2017

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

نفس الشيء بمعادلة واحدة توضع في الخلية 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

ياسر خليل أبو البراء · يوليو 14, 2017

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

**سليم حاصبيا** · يوليو 14, 2017

يمكن استعمال هذا الماكرو (الملف مرفق)صفحة 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

تسجيل الدخول

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

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

حسام فوزى

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

سليم حاصبيا

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

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

سليم حاصبيا

حسام فوزى

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

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

سليم حاصبيا

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

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

حسام فوزى

حسام فوزى

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

حسام فوزى

حسام فوزى

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

سليم حاصبيا

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

سليم حاصبيا

Join the conversation

محتوي مشابه

برنامج ادارة مخازن

سوال للخبراء بخصوص حجم الملف

الى خبراء الاكسيل

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information