نقل بيانات بشرط التكرار و توزيع للتاريخ على الصفوف

[ابوسلماان]

الاعزاء الكرام ،،

 

احتاج الى كود لنقل البيانات ولكن بشرط تكرار الصف بعدد الليالي مع اضافة تاريخ الدخول وتوزيعه كما هو موضح في الملف المرفق ،،

 

يوجد ورقتي عمل .

 

خالص الامتنان للجميع.

توزيع التاريخ.xlsm

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

 السلام عليكم و رمضان كريم

1- ليس للمرة الأولى اكرر انه لا لزوم ادراح بيانات من ألوف الصفوف (6000 صف) اذ يكفي ادراج نموذج صغير فقط

    لأن الماكرو الذي يعمل على صف واحد يمكنه العمل على الألوف منها ( فقط من ـأجل معاينه عمل الماكرو وتخفيف حجم الملف)

2-تم اخفاء بعض الاعمدة (وليس حذفها ) لمراقبة سير الكود والتمكن من رؤية الييانات/   يمكن اعادة اظهارها بسهولة

3- تم ارفاق نموذج عما تريد مع بضعة صفوف 

4-الكود

Option Explicit

Sub copy_data()
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
  End With
Dim S As Worksheet, T As Worksheet
Dim Ros#, Rot#, x%, Num%, m%

Set T = Sheets("Target_sh")
Set S = Sheets("Source_sh")

Ros = S.Cells(Rows.Count, 1).End(3).Row
If Ros < 3 Then GoTo Leave_me_alone_Please
Rot = T.Cells(Rows.Count, 1).End(3).Row
If Rot < 2 Then GoTo Leave_me_alone_Please
T.Range("A3:N" & Rot + 1).Clear
m = 3
For x = 3 To Ros
  Num = S.Cells(x, "L")
  S.Cells(x, 1).Resize(, 13).Copy
      With T.Cells(m, 1).Resize(Num, 13)
        .PasteSpecial 12
        .PasteSpecial 8
      End With
  m = T.Cells(Rows.Count, 1).End(3).Row + 2
Next
 T.UsedRange.SpecialCells(xlCellTypeConstants).Borders.LineStyle = 1
 
Leave_me_alone_Please:
     With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .CutCopyMode = False
    End With
 End Sub

الملف مرفق

 

Date_distribution.xlsm

[ابوسلماان]

شاكر لك استاذ سليم على هذا الكود ،،

واعتذر عن استعجالي في رفع الملف دون حذف الصفوف الكثيرة ،،  واتفق معك تماما في ضرورة رفع نموذج مصغر وهذا ما اقوم به دائما ،، لكن هذه المرة نسيت ذلك.

خالص امتناني لك ،، وشهر كريم عليكم جميعا ..