ترحيل التاريخ في خلية معية بجانب كل صف يتم ترحيلة في ورقة الارشيف

[مصطفى محمود مصطفى]

السلام عليكم

الملف يقوم بترحيل اعمدة متفرقة الى ورقة الارشيف  بالكود والكود للاستاذ محمد صالح جزاه الله خيرا وحاولت لعمل ترحيل  التاريخ من ورقة date c4 على كل صفوف البيانات التي يتم ترحيلها لورقة الارشيف في العمود i لكن لم تفلح المحاولة ارجو مساعدتي في كود جديد او تعديل الكود ليقوم بترحيل التاريخ من ورقةdate c4  الى ورقة الارشيف في العمود i ويكون كتابة التاريخ لجميع الصفوف المرحلة مع مراعاة ان الكود يعمل على اوفس 2019 و 2010 . ولكم كل الشكر والتقدير.

ترحيل اعمدة متفرقة.xlsm

[مصطفى محمود مصطفى]

للرفع

اضفت هذا السطر لادراج التاريخ تظهر مشاكل ممكن تعديل او طريقة اخرى لاضافة التاريخ على جميع الصفوف

.Cells(Lr + i, "j").Value = [d2]

[lionheart]

Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        a = ws.Range("B6:M" & ws.Cells(Rows.Count, "C").End(xlUp).Row).Value
        a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,6,9,10,11,12}])
        sh.Range("A7:I" & Rows.Count).ClearContents
        sh.Range("A7").Resize(UBound(a, 1), UBound(a, 2)).Value = a
        sh.Range("I7").Resize(UBound(a, 1)).Value = ws.Range("C4").Value
    Application.ScreenUpdating = True
End Sub

 

[مصطفى محمود مصطفى]

جزاكم الله خيرا استاذنا الفاضل

[مصطفى محمود مصطفى]

جزاكم الله خيرا استاذنا الفاضل

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

هل يمكن تعديل ذلك

ولكم احترامي

[lionheart]

So simple. remove the line of clearcontents 

sh.Range("A7:I" & Rows.Count).ClearContents

then specify the destination by detecting the last row. I will leave that for you. Don't wait others to do everything for you

[مصطفى محمود مصطفى]

السلام عليكم

انا مسحت السطر المذكور

لكن المشكلة لازالت حيث الترحيل توقف نهائي

ارجو التوضيح اكثر بالغاء السطر وماهي الاضافة كي يعمل الكود بشكل صحيح ويرحل البيانات تحت بعض

نحن نامل منكم المساعدة في زيادة كرمكم بتعديل الكود ليقوم بالترحيل تحت بعض

لكم وافر احترامي وتقديري

[lionheart]

Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet, m As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        a = ws.Range("B6:M" & ws.Cells(Rows.Count, "C").End(xlUp).Row).Value
        a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,6,9,10,11,12}])
        'first empty row (new line added)
        m = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1
        'change 7 in the following two lines to use the variable m instead
        sh.Range("A" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a
        sh.Range("I" & m).Resize(UBound(a, 1)).Value = ws.Range("C4").Value
    Application.ScreenUpdating = True
End Sub

 

[مصطفى محمود مصطفى]

وفقك الله وحفظكم

شكرا لكم

لكم وافر احترامي اخي العزيز

[شريف ( أبو عبدالرحمن )]

السادة الأفاضل 

عندي مشكلة الرجاء المساعدة فيها 

عايز أفكار لطريقة حل مشكلة تاريخ إستحقاق فاتورة 

((( ده موضوع قمت بمشاركته في المنتدي   )))

 

لسادة الأفاضل / عايز أفكار وحلول لمشكلة ترحيل قيمة فاتورة من خانة فواتير غير مستحقة ونسخها لخانة فواتير مستحقة عند حلول تاريخ الاستحقاق مع حذفها من عمود الفواتير الغير مستحقة 

Officna 2.XLSX