كيفية ترحيل بيانات من صفحة لاخرى

[ahmed25]

السلام عليكم

وكل عام وانتم بخير جميعا

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

الى صفحة " اليومية " وذلك بالضغط على زر حفظ مع الغاء البيانات المدخلة في صفحة ادخال بعد الحفظ لاضافة بيانات جديدة

حيث انني حاولت ولكن لم استطع لان اعمدة جدول الادخال غي متطابقة مع جدول اليومية

وشكرا جزيلا لكم

S Prog.xlsm

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

استبدل الى هذا الماكرو

Sub tarhel()
 Dim source_sh As Worksheet: Set source_sh = Sheets("أدخال") 'from
 Dim target_sh As Worksheet: Set target_sh = Sheets("اليومية") 'to
 Dim larow%
  larow = target_sh.Cells(Rows.Count, "D").End(3).Row + 1
 If larow < 4 Then  larow = 4
 Dim RO_Num%
 RO_Num = source_sh.Range("a5").CurrentRegion.Rows.Count
 target_sh.Cells(larow, 4).Resize(RO_Num - 1, 11).Value = _
 source_sh.Range("a6").Resize(RO_Num - 1, 11).Value


End Sub

 

و اضافة هذه المعادلة الى الى الخلية  C4 من الورقة اليومية والسحب نزولاً

=IF(D4="","",MAX($C$3:C3)+1)

الملف مرفق

 

SAlim_ Prog.xlsm

[ahmed25]

شكرا جزيلا على مجهودك

ولكن الكود يرحل بشكل خاطئ في الاعمدة

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

تم معالجة الامر

Option Explicit
'Created by Salim Hasbaya 2/5/2019
Sub New_tarhil()
Application.ScreenUpdating = False
 Dim arr_s(1 To 11)
 Dim arr_t(1 To 11)
 Dim i%, RO_Num%, Final_Row%
 Dim RO_s%
 Dim RGS As Range
 Dim source_sh As Worksheet
 Set source_sh = Sheets("أدخال") 'from
 Dim target_sh As Worksheet
 Set target_sh = Sheets("اليومية") 'to
  
'=================================
 RO_s = source_sh.Cells(Rows.Count, "A").End(3).Row + 1
  If RO_s = 6 Then MsgBox "No Data To Transfer": GoTo LEAVE_ME_OUT
     RO_Num = source_sh.Range("a5"). _
     CurrentRegion.Rows.Count
   Set RGS = source_sh.Range("a5"). _
     CurrentRegion.Offset(1).Resize(RO_Num - 1)
     RO_Num = RGS.Rows.Count
 Final_Row = target_sh.Cells(Rows.Count, "D").End(3).Row + 1
'=========================

   For i = 1 To 11: arr_s(i) = i:  Next
   
   For i = 1 To 3: arr_t(i) = i + 3: Next
    arr_t(4) = 9: arr_t(5) = 10
   For i = 6 To 11: arr_t(i) = i + 8: Next

      For i = 1 To UBound(arr_s)
       target_sh.Rows(Final_Row). _
       Cells(arr_t(i)).Resize(RO_Num).Value = _
       RGS.Cells(1, arr_s(i)).Resize(RO_Num).Value
      Next
      
        Erase arr_t: Erase arr_s
LEAVE_ME_OUT:
        Application.ScreenUpdating = True
End Sub

File Unclouded

 

 

SAlim_ Prog_new1.xlsm