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

[أبوســـارة1973]

السلام عليكم

رمضان كريم

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

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

 

نسخ خلايا.rar

تم تعديل يونيو 7, 2017 بواسطه أبوســـارة1973

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

ربما يكون المطلوب

 

نسخ خلايا Salim.rar

[أبوســـارة1973]

شكرا أستاذ سليم

ولكن المطلوب كود vba

[خالد الرشيدى]

السلام عليكم

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

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

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

 

تم تعديل يونيو 7, 2017 بواسطه خالد الرشيدى

[أبوســـارة1973]

شكراً أستاذ خالد الرشيدي :

يبدو أن الكود لا يعمل فلقد جربته على الملف ولكن لا يعطي نتيجة

 

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

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

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

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

 

[أبوســـارة1973]

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

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

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

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

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

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

 

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

 

[علي بطيخ سالم]

في ٧‏/٦‏/٢٠١٧ 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

[علي بطيخ سالم]

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

تم تعديل نوفمبر 19, 2018 بواسطه علي بطيخ سالم

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

ما عليك الا ان تدرس الكود خطوة خطوة

و يتضح لك جيداً ماذا يعني كل سطر و كل متغير فيه

 وعلى هذا الاساس يمكنك التعديل

[علي بطيخ سالم]

شكراً لك استاذ سليم وبارك الله فيك وجزاك الله خيراً