ترحيل عمود الى عمود وتفريغ الاول

[saadeps]

السلام عليكم 

المطلوب في المرفق بارك الله فيكم

ترحيل عمود الى عمود وتفريغ الاول.rar

[أبو حنــــين]

مرحبا

جرب المرفق

 

ترحيل عمود الى عمود وتفريغ الاول.rar

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

بارك الله فيك أخي الغالي أبو حنين

ممكن أعرف ليه التعقيد في سطر الـ Union ؟؟!!

بدلاً من استخدام السطر بالشكل التالي

Union(Range(Cells(i, 4), Cells(i, 4)), Range(Cells(i, 6), Cells(i, 6))).Copy

يمكن استخدامه بالشكل التالي

Union(Range("D" & I), Range("F" & I)).Copy

بسطها يا كبير .. ويا ريت بعد إذنك لو مكانش يضايقك .. دا إذا مكانش يضايقك طبعاً 

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

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

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

بعد اذن الاخ ياسر والاخ أبو حنين

هذا الكود (بدون حلقات تكرارية حيث ان ابو البراء لا يجبذها)

Sub salim()
Dim My_Rg As Range
Dim t As Integer
Set My_Rg = Union(Sheets("sheet1").Range("d5").Resize(Cells(Rows.Count, 4).End(3).Row - 4, 1) _
    , Sheets("sheet1").Range("f5").Resize(Cells(Rows.Count, 6).End(3).Row - 4, 1))
  t = Application.CountA(My_Rg): If t = 0 Then Exit Sub
    Range("h5:j100").ClearContents
            With My_Rg
                .Areas(1).Copy Destination:=Range("h5")
                .Areas(2).Copy Destination:=Range("i5")
                .ClearContents
             End With

Sheets("sheet1").Range("j5").Resize(Cells(Rows.Count, 8).End(3).Row - 4, 1) _
.FormulaR1C1 = "=RC[-2]-RC[-1]"
End Sub

 

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

بارك الله فيك أخي العزيز سليم

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

Sub Test()
    Dim Lr As Long, startRow As Long
    startRow = 5
    With ActiveSheet
        Lr = .Cells(Rows.Count, "D").End(xlUp).Row
        .Range("H" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("D" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("I" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("F" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("J" & startRow).Resize(Lr - (startRow - 1)).Formula = "=RC[-2]-RC[-1]"
    End With
End Sub

يمكن التعديل رقم 5 حيث يمثل صف البداية للبيانات المراد التعامل معها

تقبلوا تحياتي

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

1 دقيقه مضت, ياسر خليل أبو البراء said:

بارك الله فيك أخي العزيز سليم

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

Sub Test()
    Dim Lr As Long, startRow As Long
    startRow = 5
    With ActiveSheet
        Lr = .Cells(Rows.Count, "D").End(xlUp).Row
        .Range("H" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("D" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("I" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("F" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("J" & startRow).Resize(Lr - (startRow - 1)).Formula = "=RC[-2]-RC[-1]"
    End With
End Sub

يمكن التعديل رقم 5 حيث يمثل صف البداية للبيانات المراد التعامل معها

تقبلوا تحياتي

بارك الله فيك اخي الحبيب ياسر

لكن انا ارى انه لا بد من هذا السطر في الكود

t = Application.CountA(My_Rg): If t = 0 Then Exit Sub

و ذلك من اجل تفادي محي البيانات قي النتائج في حال قام المستخدم بتنفيذ الكود اكثر من مرة قبل اضافة بيانات جديدة

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

جزيت خيراً أخي العزيز سليم على قوة الملاحظة

لم أنتبه لمسح النطاق بعد الترحيل ..

إليك التعديل التالي ليناسب المشكلة في حالة تكرار الكود

Sub Test()
    Dim Lr As Long, startRow As Long
    
    startRow = 5
    
    With ActiveSheet
        Lr = .Cells(Rows.Count, "D").End(xlUp).Row
        If Lr < startRow Then MsgBox "Put Some Data", vbExclamation: Exit Sub
        
        .Range("H" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("D" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("I" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("F" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("D" & startRow & ":F" & Lr).ClearContents
        .Range("J" & startRow).Resize(Lr - (startRow - 1)).Formula = "=RC[-2]-RC[-1]"
    End With
End Sub

 

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

18 دقائق مضت, ياسر خليل أبو البراء said:

جزيت خيراً أخي العزيز سليم على قوة الملاحظة

لم أنتبه لمسح النطاق بعد الترحيل ..

إليك التعديل التالي ليناسب المشكلة في حالة تكرار الكود

Sub Test()
    Dim Lr As Long, startRow As Long
    
    startRow = 5
    
    With ActiveSheet
        Lr = .Cells(Rows.Count, "D").End(xlUp).Row
        If Lr < startRow Then MsgBox "Put Some Data", vbExclamation: Exit Sub
        
        .Range("H" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("D" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("I" & startRow).Resize(Lr - (startRow - 1)).Value = .Range("F" & startRow).Resize(Lr - (startRow - 1)).Value
        .Range("D" & startRow & ":F" & Lr).ClearContents
        .Range("J" & startRow).Resize(Lr - (startRow - 1)).Formula = "=RC[-2]-RC[-1]"
    End With
End Sub

 

بارك الله بك من جديد

ملاجظة اخيرة 

لماذا لا ندع الاكسل نفسة يحدد startRow من خلال هذا السطر

startRow = Range("d1").End(xlDown).Row+1

 

تم تعديل أغسطس 28, 2016 بواسطه سليم حاصبيا

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

ماذا لو كان هناك خلية في النطاق D2:D4 غير فارغة  ؟؟ استخدام xlDown قد يسبب مشاكل في حالة وجود خلايا غير فارغة حيث أنه لن يعطي نتائج صحيحة في هذه الحالة

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

جزاك الله خيراً أخي العزيز سليم

[saadeps]

بعد التحية والسلام الى كل الاخوة الكرام الذين اهتمو بسؤالي 

استسمحكم عذرا لاني الان دخلت الى الموقع الرائع اوفيسنا

اجدد لكم تشكراتي على ارسال الكود 

الكود ناجح في ترحيل البيانات من العمود D الى العود H و E الى I

ولكن هناك جزئية مهمة اريدها  وهي 

لما يكون مثلا ف العمود H بيانات سابقة اود بعد ترحيل البيانات الجديدة من العمود D ان تضاف اليها بالجمع 

مثلا توجد قيمة 10 في العمود  1 H بعد ترحيل قيمة 12 من D1 تصبح النتيجة 22 في العمود 1 H

ارجو ان اكون قد وفقت في توصيل المطلوب

وجزاكم الله خير الجزاء في الدنيا والاخرة

 

تم تعديل أغسطس 28, 2016 بواسطه saadeps

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

تم العمل على الملف كما تريد

 

 

ترحيل عمود الى عمود وتفريغ الاولsalim.rar

[saadeps]

بارك الله فيك استاذ انه المطلوب

ارجو المعذرة اللحظة دخلت الى الموقع لاسباب شخصية

ارجو ان تتقبل تحياتي  وبارك الله فيك مرة ثانية

 

[حسين مامون]

استاذ سليم عمل  رائع سنستفيذ منه جميعا حفظكم الله