اضافة سطر جديد مع ترحيل البيانات

[طارق_طلعت]

السيد الفاضل عبد الفتاح

الملف بة كود يقوم بترحيل البيانات من الشيت الأول (الترحيل) الى الشيتات الأخرى طبقا لآسم الشيت

و المطلوب ان يتم ترحيل البيانات لكل شيت داخل صف جديد يبدأ من بعد اخر خلية بها بيانات بالعمود A

و مرفق ملف بة النتيجة المطلوبة (الصفوف باللون الآصفر) ..انا الحمد للة عرفت اضيف الصف و ارحل فية البيانات

لكن الجزء اللى مش عارف اعملة هو سحب المعادلات الموجودة بأخر عمودين الى السطر الجديد (او عمل COPY و PASTE) لآخر خليتين فى العمود 

الحسابات.xlsm

[محمد هشام.]

السلام عليكم ورحمة الله وبركاته ..جرب وضع هدا الكود اخي

Sub ترحيل_قيود()
ActiveSheet.unprotect
Set ws = ActiveWorkbook.Sheets("الترحيل)
Dim cl As Range, i As Integer
For i = 1 To Sheets.Count
Application.ScreenUpdating = False
For Each cl In ws.Range("a13:a" & ws.[a10000].End(xlUp).Row)
If cl.Value = Sheets(i).Name Then
Sheets(i).Range("a" & Sheets(i).[a10000].End(xlUp).Row + 1).EntireRow.Insert
Sheets("الترحيل").Select
cl.Offset(0, 2).Resize(1, 5).Copy
Sheets(i).Range("a" & Sheets(i).[a10000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
Next
Call y

Application.ScreenUpdating = True
End Sub
Sub y()
Dim LR As Long
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
    Select Case ws.Name
        Case "100-1", "100-2", "200-1", "200-2", "200-3", "200-4"
LR = ws.Range("c" & ws.Rows.Count).End(xlUp).Row
ws.Range("E" & LR).Formula = "=Sum(E16:E" & LR - 1 & ")"
ws.Range("d" & LR).Formula = "=Sum(d16:d" & LR - 1 & ")"
ws.Range("f" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]"
ws.Range("g" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]"
 End Select
Next ws
Worksheets("الترحيل").Activate
End Sub

الحسابات.xlsm

[طارق_طلعت]

استاذ محمد هشام ..شكرا جزيلا على المساعدة ..بتجربة الكود بينسخ المعادلات فى الصف اللى اسفل الصف المضاف

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

انا عاوز طريقة تنفذ المطلوب مع الترحيل لكل شيت ضمن تفس حلقة FOR و NEXT الخاصة بالترحيل ..مرة اخرى شكرا جزيلا على المساعدة 

 

[محمد هشام.]

الكود ينسخ المعادلات في صف الإجمالي. هو المفروض يتم نسخ المعادلة في أي صف ؟ 

  . اما بالنسبة لاضافة المعادلات لجميع الشيتات  يمكنك جعل الكود بهده الطريقة

Sub y()
Dim LR As Long
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
   LR = ws.Range("c" & ws.Rows.Count).End(xlUp).Row
   If (ws.Name <> "الترحيل") Then
With ws
ws.Range("E" & LR).Formula = "=Sum(E16:E" & LR - 1 & ")"
ws.Range("d" & LR).Formula = "=Sum(d16:d" & LR - 1 & ")"
ws.Range("f" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]"
ws.Range("g" & LR).FormulaR1C1 = "=RC[-1]-RC[-2]"
      
End With
End If
Next ws
End Sub

 

 

[طارق_طلعت]

صباح الخير استاذ محمد ..شاكر جدا لمساعدة حضرتك

بس للأسف الكود كدة حينسخ المعادلة فى كل شينات الملف 

انا عاوز انسخ المعادلة فى الشيتات التى سيتم الترحيل لها فقط اللى هى اسمائها موجودة فى صفحة الترحيل عمود A

انا ارفقت ملف مصغر فقط للتوضيح لكن الملف الأصلى اكتر من 1500 شيت لكن الترحيل بيتم فى عدد قليل من الشيتات طبقا للقيود

و شكرا جزيلا 

[محمد هشام.]

العفو أخي الكريم..

على حسب مافهمت من طلبك الكود الأول يوفي بالغرض لانك سوف تعرف فقط أسماء الشيتات الذي يتم الترحيل لها فقط . على العموم كنت أتمنى مساعدتك لاكن للأسف لم أستوعب الفكرة جيدا 

[طارق_طلعت]

شكرا اخى العزيز ..سأطرح موضوع جديد بالفكرة بشكل مبسط  ..شكرا جزيلا

من فضلك كمل موضوعك هنا  فممنوع تكرار نفس المشاركات