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

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


إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

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

السلام عليكم

رمضان كريم

هل ممكن أن أحصل على كود يقوم بنسخ قيمة خلية ما في خلايا عمود بحسب العدد المدون في الخلية المقابلة لها؟

الشرح في الملف المرفق

 

نسخ خلايا.rar

تم تعديل بواسطه أبوســـارة1973
رابط هذا التعليق
شارك

السلام عليكم

بعد اذن استاذي / سليم حاصبيا

اخى الكريم جرب الكود التالى كأحد طرق الحل

Sub Khaled()

    Dim cll As Range ,Dim Lr As Long
    Range("C3:C1000").ClearContents
    
    For Each cll In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
        Lr = Cells(Rows.Count, "C").End(xlUp).Row
        cll.Copy Destination:=Range("C" & Lr + 1 & ":C" & Lr + cll.Offset(, 1).Value)
    Next

End Sub

 

تم تعديل بواسطه خالد الرشيدى
رابط هذا التعليق
شارك

  • أفضل إجابة

أخي الكريم أبو سارة .. جربت كود الأخ الحبيب خالد ويعمل بشكل جيد جداً

عموماً إثراءً للموضوع هذا كود آخر مقارب لكود الأخ خالد لعله يفيدك

Sub PopulateNumbers()
    Dim cell    As Range
    Dim x       As Long
    Dim lr      As Long

    Range("C3:C1000").ClearContents
    
    For Each cell In Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        x = cell.Offset(, 1)
        lr = Cells(Rows.Count, 3).End(xlUp).Row + 1
        Range("C" & lr).Resize(x, 1).Value = cell.Value
    Next cell
End Sub

 

  • Like 2
رابط هذا التعليق
شارك

ألف شكر لك حبيبي ياسر خليل أبو البراء

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

في ميزان حسناتك وبارك الله لك

والشكر موصول لكل من ساعدني في هذا العمل جزاكم الله خير الجزاء

  • Like 1
رابط هذا التعليق
شارك

زيادة في اثراء الموضوع هذا الكود

 

Option Explicit
Sub copy_as_you_want()
Dim i, c As Integer
Dim Cont
Dim Lr As Long
Lr = ActiveSheet.Cells(Rows.count, 3).End(3).Row

Range("c3:c" & Lr).ClearContents
i = 3
c = 3

  Do While Cells(i, 1) <> ""
    Cont = Cells(i, 1).Offset(0, 1).Value
        If Not IsNumeric(Cont) Or Cont = "" Or Cont = 0 Then i = i + 1: GoTo 1
        Cont = Int(Abs(Cont))
     Range("c" & c & ":c" & c + Cont - 1).Value = Cells(i, 1).Value
    i = i + 1
    c = c + Cont
1:
  Loop
End Sub

 

  • Like 1
  • Haha 1
رابط هذا التعليق
شارك

  • 1 year later...
في ٧‏/٦‏/٢٠١٧ at 16:29, سليم حاصبيا said:

زيادة في اثراء الموضوع هذا الكود

 


Option Explicit
Sub copy_as_you_want()
Dim i, c As Integer
Dim Cont
Dim Lr As Long
Lr = ActiveSheet.Cells(Rows.count, 3).End(3).Row

Range("c3:c" & Lr).ClearContents
i = 3
c = 3

  Do While Cells(i, 1) <> ""
    Cont = Cells(i, 1).Offset(0, 1).Value
        If Not IsNumeric(Cont) Or Cont = "" Or Cont = 0 Then i = i + 1: GoTo 1
        Cont = Int(Abs(Cont))
     Range("c" & c & ":c" & c + Cont - 1).Value = Cells(i, 1).Value
    i = i + 1
    c = c + Cont
1:
  Loop
End Sub

 

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

ارجوا التعديل.xlsx

رابط هذا التعليق
شارك

جرب هذا الشيء

الكود

Option Explicit
Sub give_data()
Dim My_sh As Worksheet
Set My_sh = Sheets("salim")
If ActiveSheet.Name <> My_sh.Name Then Exit Sub
Dim i As Byte
Dim Fasl$
Dim m%: m = 2

With My_sh
 
 Dim rg As Range: Set rg = .Range("d3:d6")
 .Range("B2:b" & Rows.Count).ClearContents
  For i = 1 To 4
  Fasl = rg.Cells(i).Offset(, 1) & " "
 .Range("b" & m).Resize(rg.Cells(i)) = Fasl
  m = m + rg.Cells(i)
  Next
End With
End Sub

الملف

 

tekrar_Salim.xlsm

  • Thanks 2
رابط هذا التعليق
شارك

ممتاااااااااااااااااااااااااااااز لكن كيف أطبقه على ملف آخر  يعني لو نقلت الكود لملف آخر مع تغيير الأعمدة والصفوف ما هو المفترض أقم بتغييره في هذا الكود والمعذرة لأني ضعيف في الفيجوال بارك الله فيك استاذ سليم ودائماً أنت المتصدر وفقك الله 

تم تعديل بواسطه علي بطيخ سالم
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information