ايجاد الفروق بين رقمين وكتابتة في خلايا اخرى

[honey22]

السلام عليكم 

كيفكم شباب

 

اريد منكم المساعدة في الاكسل واريد ايجاد معادلة او اي حل للموضوع الذي سوف اتكلم عنة

 

عندي كروت وبها ارقام تسلسلية وعددها كثير

مثلا من رقم ١٠٠١ الى رقم ٢٠٠٠٠ 

وصعب ان أكتبها او اعمل لها سحب وافلات

وفي بعض الاحيان تكون الارقام اكثر او اقل

والمطلوب هو ايجاد الفرق بين الرقمين

الارقام الذي بين ١٠٠١ و٢٠٠٠٠ وكتابتها في عمود محدد

يبدا بالرقم ١٠٠١ وينتهي بالرقم ٢٠٠٠٠

 

وللتوضيح اكثر 

مثلا اريد ان اكتب في الخلية B1 رقم ١٠٠١ وفي الخلية C1 ٢٠٠٠٠ ويتم كتابة الارقام تسلسلية في الخلية A1 الى  نهاية الرقم المكتوب في الخلية C1

الذي سوف ينكتب في الخلية A1 هو ١٠٠١

والخلية A2 هو ١٠٠٢ وبعدها ١٠٠٣ و١٠٠٤ و١٠٠٥ الى نهاية ٢٠٠٠٠

 

ولكم جزيل الشكر والاحترام

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

وعليكم السلام أخي الكريم

أهلا بيك في المنتدى ونورت بموبايلك .. حاول ترفق ملف في أي موضوع قادم إن شاء الله

عموماً جرب الكود التالي .. عله يفي بالغرض إن شاء الله

Sub Test()
    Dim a As Variant
    Dim i As Long
    Dim x As Long
    Dim s As Long
    Dim e As Long
    Dim k As Long

    ReDim a(1 To 100000)
    For x = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        If IsNumeric(Cells(x, 2)) And IsNumeric(Cells(x, 3)) And Cells(x, 2) <> 0 And Cells(x, 3) <> 0 Then
            s = Cells(x, 2).Value: e = Cells(x, 3).Value
            For i = s To e
                k = k + 1
                a(k) = i
            Next i
        End If
    Next x
    Range("A2").Resize(k).Value = Application.Transpose(a)
End Sub

 

[honey22]

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

وعليكم السلام أخي الكريم

أهلا بيك في المنتدى ونورت بموبايلك .. حاول ترفق ملف في أي موضوع قادم إن شاء الله

عموماً جرب الكود التالي .. عله يفي بالغرض إن شاء الله

Sub Test()
    Dim a As Variant
    Dim i As Long
    Dim x As Long
    Dim s As Long
    Dim e As Long
    Dim k As Long

    ReDim a(1 To 100000)
    For x = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        If IsNumeric(Cells(x, 2)) And IsNumeric(Cells(x, 3)) And Cells(x, 2) <> 0 And Cells(x, 3) <> 0 Then
            s = Cells(x, 2).Value: e = Cells(x, 3).Value
            For i = s To e
                k = k + 1
                a(k) = i
            Next i
        End If
    Next x
    Range("A2").Resize(k).Value = Application.Transpose(a)
End Sub

شكراً اخي الكريم على الرد السريع والمعذرة لتاخري عن فتح الموقع 

وبخصوص الملف لم استطع ان ارفعة للموقع

هل هناك طريقة لرفعة

 

تم تعديل يوليو 15, 2017 بواسطه honey22
لم اكتب شي

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

يا سيدي ولا يهمك

بالنسبة لرفع الملفات بتضغط الملف (بأي برنامج ضغط زي الوينرار) وترفعه من خلال النقر على "اختر ملف" ..

هل جربت الكود أم أنك لا زلت على الموبايل :)

[honey22]

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

يا سيدي ولا يهمك

بالنسبة لرفع الملفات بتضغط الملف (بأي برنامج ضغط زي الوينرار) وترفعه من خلال النقر على "اختر ملف" ..

هل جربت الكود أم أنك لا زلت على الموبايل :)

نعم جربتة واضهر خطاء وسوف ارسل لك الصور

وبالنسبة لرفع الملف لايوجد بهاتفي الى رفع صور فقط لايسمح بالدخول لغير الصور هذة من خدمات الايفون  وسوف ارفق صورة بذلك

ومشكور اخي ياسر على ردك والشكر قليل جداً في حقك ولكن نسال من الله بان يكتبة في حسناتك 

 

تم تعديل يوليو 16, 2017 بواسطه honey22

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

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

أو راجع الملف لربما يكون اسم ورقة العمل مختلف لديك مثلاً .. 

[ابراهيم الحداد]

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

جرب هذا الكود

Sub GoodsAcc3()
Dim Arr As Variant
Dim i As Integer, j As Integer, x As Integer, y As Integer, p As Integer
Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).ClearContents
For i = 2 To 5
For x = Cells(i, 3) To Cells(i, 4)
If x Then
j = j + 1
Cells(j + 1, 2) = x
End If
Next
Next
End Sub

 

تم تعديل يوليو 16, 2017 بواسطه زيزو العجوز

[honey22]

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

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

أو راجع الملف لربما يكون اسم ورقة العمل مختلف لديك مثلاً .. 

المعذرة منك اخي العزيز على التاخير حيث والنت عندنا صعب وعدة موانع

واليك هذة الملفات وحيث ليست عندي الخبرة الكافية في الماكرو

ولك كل الشكر والتقدير

وكذلك ارفقت لك في ورقة المطلوب ايجادة

اكسل.rar

[honey22]

في ١٦‏/٧‏/٢٠١٧ at 23:01, honey22 said:

المعذرة منك اخي العزيز على التاخير حيث والنت عندنا صعب وعدة موانع

واليك هذة الملفات وحيث ليست عندي الخبرة الكافية في الماكرو

ولك كل الشكر والتقدير

وكذلك ارفقت لك في ورقة المطلوب ايجادة

اكسل.rar

اخي ياسر لقد قمت برفع الملف ولم يتم الرد

 

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

لقد قام الأخ زيزو بتقديم حل ..هل جربته؟ ما هي المشكلة التي تواجهك الآن؟ حاول توضح المشكلة بعد تجربة الكود أعلاه

[honey22]

في Tuesday, July 18, 2017 at 00:00, ياسر خليل أبو البراء said:

لقد قام الأخ زيزو بتقديم حل ..هل جربته؟ ما هي المشكلة التي تواجهك الآن؟ حاول توضح المشكلة بعد تجربة الكود أعلاه

السلام عليكم

 

الاخ ياسر والاخ زيزو اشكركم على التجاوب معي واعطائي الاكواد البرمجية ومشكورين ماقصرتو

والحمدلله اشتغل معايا الملف 

ولكن للاسف الشديد لم اقم انا بكتابة الاكواد في الملف الاكسل ولكن استعنت باحد الاصدقاء

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

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

المهم ما اطول معاكم

الملف اشتغل ولكن ناقصة الكثير من التعديل

وعندما حاولت اعدل فية اتفاجا بانة محمي ضد التعديل ومحمي بكلمة مرور وهذة كانت مفاجاة لي من صديقي ولا اعلم لماذا عمل الحماية وكلمة المرور 

وحتى الان لااعلم ماهو الكود الذي كتبة هل هو كود الاخ ياسر ام كود الاخ زيزو ام غيرهم الاثنين

 

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

ومشكورين وبارك الله فيكم وزادكم علماً من فضلة

 

AutoFill.zip

[honey22]

في ١٨‏/٧‏/٢٠١٧ at 00:00, ياسر خليل أبو البراء said:

لقد قام الأخ زيزو بتقديم حل ..هل جربته؟ ما هي المشكلة التي تواجهك الآن؟ حاول توضح المشكلة بعد تجربة الكود أعلاه

مشكورين انت والاخ زيزو وبارك الله فيكم وماقصرتو 

بس اعتقد التقصير مني انا لقلة خبرتي في الاكسل وخاصتاً الاكواد في الماكرو

وقد قمت بكتابة الكود الاول ولكن لم يعمل اعتقد مثلما قلت انت تسمية الملف

وقد قمت برفع الملف

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

ولكم كل الشكر والتقدير 

والمعذرة منكم والمسامحة

لماذا لايوجد رد ارجو ممن لدية الخبرة بان يرد 

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

أخي الكريم شاهد الفيديو التالي أولاً وحاول بنفسك .. وإذا تعثرت في أمر ما اذكر ما تعثرت فيه وحاول دائماً أن ترفق الملف الذي تود العمل عليه ..