نسخ عدد معين من الخلايا بناءا علي قيمة خليه بها هذا العدد

[Darmear]

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

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

بمناسبة عيد الاضحي المبارك

هذه اول مشاركة لي بهذا المنتدي الرائع

ارجو مساعدتي ممن لدية الخبرة 

سؤالي هو

لديك خليه ما بها رقم يتم ادخاله يدويا 

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

ثانيا يقوم بنسخ عدد من الخلايا يساوي ضعف هذا الرقم

مثال 

الخليه A1=4

اذا ينسخ النطاق C5:C13

النطاق المنسوخ ضعف الرقم الموجود

مع العلم ان بداية النسخ ثابته وهي الخليه C5 

فقط وليس اكثر وشكرا لكم

 

تم تعديل أغسطس 20, 2018 بواسطه Darmear
خطا

[Ali Mohamed Ali]

أهلا وسهلا بك اخ كريم فى المنتدى وكل عام وانتم بخير

طلبك ليس واضح كفاية -عليك برفع ملف وشرح ماذا تريد عليه بالتفصيل

بارك الله فيك

 

[Darmear]

 

 

تم تعديل أغسطس 20, 2018 بواسطه Darmear

[Darmear]

تفضل اخي  وشكرا للرد 

اتمني ان تكون وصلت للمطلوب 

Book1.xls

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

جرب هذا الملف

Salim1.xlsm

[Darmear]

بداية اشكرك جزيلا للمحاوله

ولكنه ليس المطلوب 

اريد كما بالملف الذي رفعته اليك وكما بالصورة التالية 

عند ادخال عدد الي الخليه 

ثم الضغط على الذر 

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

في هذا الملف اذا ضغطت على الذر يقوم بنسخ الخلايا 

اريد ان يكون هناك شرط وهو قيمة الخليه D9

اذا كانت القيمة مثلا 4 عند الضغط على الذر يقوم يتحديد ونسخ الخلايا بداية من الخليه I12 والي عدد ضعف العدد المدخل في الخلية D9 سيكون في مثالنا هذا الي الخلية I19

هل وضحت الصورة 

Book1.xls

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

ربما كان هذا المطلوب

 

 

Salim2.xlsm

[Darmear]

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

وبعد تعديلات كثيره على كودك الاول وصلت لهذا الكود وعمل بنجاح

لا افهم ماذا يعني فالرجاء منك شرحه سطر سطر 

الرقم في الخليه e9 هل ممكن احذف السطر d9

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

Sub textx()

 

Dim mY_cel: mY_cel = Range("d9").Value

Dim counnt%

 counnt = IIf(Not IsNumeric(Range("e9")) _

 Or Range("e9") <= 0, 8, Range("e9"))

 Range("o28").Resize(counnt, 1).Select

Selection.Copy

End Sub

[Darmear]

هذا هو الملف المطلوب 

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

 

Book1.xls

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

اولاً: لم افهم ماذا تريد ان تفعل انت قنت بتحديد نطلق معين ثم عملت له Copy

ثانياً: لنسخ الكود ز ليظهر بشكل صحيح اتبع الصورة

[Darmear]

شكرا لك 

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

 

Book1.xls

فعلا ما اريده تحديد نطاق معين ثم نسخه وفقط

لكن النطاق يعتمد علي شرط 

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

واريد ان احذف الزيادات فيها ان كان فيها زيادات

[Darmear]

اتمني الا اكون ازعجتك كثيرا بخبرتك نستفيد

هل من الممكن نسخ عمودين فوق بعض عند اللصق

مثال

الملف مرفق

عند الضفط على ذر نسخ ينسخ عمود واحد فقط اريده ان ينسخ العمودين فوق بعض ويظهر عند اللصق في مكان اخر بنفس الترتيب كما في المثال المرفق

اتمني ان تكون فهمتني

 

Book2.xls

نفس الطريقه التي بالفيديو ولكن اريدها بماكرو او كود ليتم اضافتها لذر عند الضغط عليه يقوم بهذه المهمه

شكرا جزيلا لحضرتك

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

ارفع ملفاً عما تريد

يحتوي على الموجود في الصفحة الاولى مع بيانات عشوائية(ليس خلايا فارغة) و النتيجة التي تتوقعها في صفحة ثانية

[Darmear]

شكرا لاهتمامك وانا منتظر ردك جدا ولا افعل اي شي الا انتظارك

في هذا الملف

اريد عند الضغط علي كلمة نسخ يحدث الاتي 

يتم نسخ البيانات الملونه

وعندما اضغط كلك يمين والصقها يدويا تكون النتيجه كما في الشيت الثاني

فهمتني

انا اريد فقط نسخ اما اللصق فانا افعله يدويا في اي مكان اريده

Book2.xls

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

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

Option Explicit
Sub COPY_CELLS()
Sheets("النتيجه").Range("a2").CurrentRegion.Clear
Dim My_RG As Range
Set My_RG = Sheets("Sheet1").Range("h6").CurrentRegion
 My_RG.Columns(1).Copy Sheets("النتيجه").Range("a2")

 My_RG.Columns(2).Copy Sheets("النتيجه"). _
 Range("a2").Offset(My_RG.Columns(1).Rows.Count)
End Sub

 

[Darmear]

جربته وكانت النتيجه جميله ولكن لا يتضح انك تفهمني جيدا

عندما جربته قام بنسخ الخلايا التي اريدها تمام

ولكن لماذا لصقها 

لا اريده ان يلصقها بل الصقها انا يدويا اي تكون مخزنه بالذاكرة 

ثانيا هناك خلية فارغه بين النسخين كما بالصورة !!! لماذا حدث ذلك

Sub Macro3()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer

Set Range1 = Range("h7:i16")
Set Range2 = Range("k7")
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

ما رايك يهذا الكود

لكن به مشكله واحده

لا اريده ان يلصق لا اريده ان يعمل paste 

اريده فقط ان ينسخ بالتنسيق المطلوب اي نسخ العمودين فوق بعض

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

[Darmear]

اتمني ان تري الفيديو المرفق

 

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

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

اذ انه قام بنسخ العامود الاول و يجب عليه ان يلصقه في مكان ما قبل ان يقوم بنسخ العامود الثاني الى مكان أخر

يمكن عمل ذلك من خلال InputBox ,ولكن ذلك من الماكروات المتقدمة بعض الشيء ( وانت ما زلت مبتدءأً أصبر قليلاً)

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

Range("a2").Offset(My_RG.Columns(1).Rows.Count)

 بهذا السطر
Range("a2").Offset(My_RG.Columns(1).Rows.Count-1)

 

3 دقائق مضت, Darmear said:

اتمني ان تري الفيديو المرفق

 

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

[Darmear]

شكرا جزيلا لك واقدر تعبك معي جدا واعرف اني ازعجك بكلامي 

ولكن الامر هام جدا جدا لي ولا افهم كيفيه عمله جيدا 

افتح حضرتك هذا الملف واضغط على الذر فلاحظ ما سيحدث فهو بالظبط ما اريده 

ولكن

لا اريده ان يلصقه فقط اريده ان يحدده وينسخه فقط ليس اكثر

Book2.xls

ولا اريده عن طريق inputbox فقد جربته وعدلت عليه لاعطي لك هذا الكود

 

[Darmear]

حتي لا ازعجك فلنرجع للكود الاول

فيكفيني هذا اليوم وكويس جدا اني وصلت لهذه المرحله عسي ان ابحث جيدا على النت واجد ما اريد

Sub textx()
Dim counnt%
 counnt = IIf(Not IsNumeric(Range("e9")) _
 Or Range("e9") <= 0, 8, Range("e9"))
 Range("i12").Resize(counnt, 1).Select
Selection.Copy
End Sub

بالنسبه لهذا الكود يعمل بروعه لا مثيل لها

فما هو الشرح لهذه المعادله 

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

تم تعديل أغسطس 20, 2018 بواسطه Darmear

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

اذا كنت تريد يمكن عمل هذا بالمعادلات اكتب هذه المعادلة اينما تريد و اسحبها نزولاً

=IF(ROWS($A$1:A1)>COUNTA($H$7:$I$50),"",INDEX($H$7:$I$50,INT((ROWS($A$1:A1)-1)/2)+1,MOD((ROWS($A$1:A1)-1),2)+1))

الملف المرفق فيه المعادلة والنتيجة

 

Book_Salim1.xls

[Darmear]

لم اخطىء ابدا في كلمة انك لعبقري 

ادهشتني جدا النتيجه

فعلا انك رائع شكرا جزيلا لك

 

هل من الممكن ان يختلف الترتيب قليلا ليكون العمود الاول ثم الثاني

1

2

3

4

الخ

a

b

c

d

الخ

 

لقد تم تعديل الرد

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

طبعاً ممكن 

 

Book_Salim2.xls

[Darmear]

رائع تسلم ايدك وشكرا جزيلا جزيل الشكر لحضرتك

كده اكتملت الصورة تمام 
 

[Darmear]

للاسف هناك خطأ لا اعرف مصدره 

اليك الملف تاكد بنفسك

Book_Salim2 (1).xls