ترحيل بيانات من عدة صفحات الى صفحة واحدة

[حسين مامون]

السلام عليكم ورحمة الله

عندي في الملف المرفق شيتات مرقمة من 1 الى غير محدد

واريد ان شاء الله ما يلي

1- ادا كان العمود(j)فيه بيانات   من كل صفحة ينسخها مع العمود (h)وكذلك الخلية(b1)

2- اضافة صف فارغ ملون بين اسم واخر  كما في النمودج

3- تلصق البيانات في صفحة الديون  المدى(e4:g)

جزاكم الله خيرا

Nouveau Archive WinRAR (4).rar

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

جرب هذا الملف

اصنافform salim.rar

[حسين مامون]

السلام عليكم ورحمة الله

استاذنا سليم حاصبيا  الف شكر  

الكود يعمل ولكن يحتاج الى تعديل ، لانه لاينسخ جميع البيانات  فمثلا الصفحة 1 العمود j  فيه 17 قيمة نسخ منها 15 قيمة فقط وكذلك باقي الصفحات 

لو سمحت ممكن تعيل الكود  وشرح التعديل

جزاك الله خيرا

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

  في 29‏/4‏/2017 at 07:15, حسين مامون said:

السلام عليكم ورحمة الله

استاذنا سليم حاصبيا  الف شكر  

الكود يعمل ولكن يحتاج الى تعديل ، لانه لاينسخ جميع البيانات  فمثلا الصفحة 1 العمود j  فيه 17 قيمة نسخ منها 15 قيمة فقط وكذلك باقي الصفحات 

لو سمحت ممكن تعيل الكود  وشرح التعديل

جزاك الله خيرا

Expand  

لو امكن ان ترفع جزء من الملف حوالي 20 صف غي كل صفحة

لمعرفة كيفية التعامل مع الملف حيث اني اري معادلات لا تعمل كما يجب

و حدد ماذا تريد ان ترقم في العامود A  هل 1 2   أو   الرقم 1   الرقم 2   لان الفلتر يتأثر بهذا

تم تعديل أبريل 30, 2017 بواسطه سليم حاصبيا

[حسين مامون]

السلام عليكم ورحمة الله

اساذي سليم حاصبيا

ارجو ان تقبل اعتذاري لتأخري في الرد وذلك لاسباب شخصية 

في المرفق شرح لما اريد  وارجو ان يكون كافيا

جزاك الله خيرا 

Nouveau Archive WinRAR (5).rar

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

تم تغيير الكود(انسخه الى موديل جديد و عين له زراً للتنفيذ)

Option Explicit
Option Base 1
Sub Salim_Extract()
Dim Src_Sh As Worksheet
Dim Trg_Sh As Worksheet
Dim xx, lr, m, My_Row As Integer
 Dim ArrJ(), ArrG()
Dim t As Long
Application.ScreenUpdating = False
My_Row = 4
Set Trg_Sh = Sheets("الديون")

Trg_Sh.Range("e4").Resize(10000, 3).Clear
 For m = 3 To Sheets.Count - 2
 t = 1
   Set Src_Sh = Sheets(m)
     With Src_Sh
    .Select
        On Error GoTo 1
         On Error Resume Next
         lr = .Cells(Rows.Count, "j").End(3).Row

             For xx = 4 To lr

               If .Cells(xx, "j") > 0 And Cells(xx, "j") <> "" Then
                ReDim Preserve ArrJ(t)
                ReDim Preserve ArrG(t)
               ArrJ(t) = .Cells(xx, "j").Value
               ArrG(t) = .Cells(xx, "G").Value: t = t + 1
               End If
            Next

      End With
    

Trg_Sh.Range("g" & My_Row).Resize(UBound(ArrJ)) = Application.Transpose(ArrJ)
Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)) = Application.Transpose(ArrG)
Trg_Sh.Range("e" & My_Row).Resize(UBound(ArrG)) = Sheets(m).Cells(1, 2)
 Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)).NumberFormat = "m/d/yyyy"
My_Row = My_Row + t
Trg_Sh.Range("e" & My_Row - 1).Resize(, 3).Interior.ColorIndex = 6
1:
 Erase ArrJ: Erase ArrG
Next
Application.ScreenUpdating = True
Trg_Sh.Activate: Range("e3").Select
End Sub

الملف المرفق 

اصنافform salim 1.rar

[حسين مامون]

اشكرك اخي هذا عمل ممتاز 

جعله الله في ميزان حسناتك

جزاك الله خيرا