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

[هانى محمد]

السلام عليكم أحبائى الكرام أرجو التكرم من حضراتكم على مساعدتى فى ايجاد كود ترحيل من صفحة Main الى باقى صفحات الملف بما يتناسب مع كل اسم صفحة الموجود بالعمود P من صفحة Main

ولصق البيانات بكل جدول من الصفحة فالجدول لا يأخذ أكثر من 30 صف ... فاذا زادت البيانات المرحلة فليكن فى الجدول الذى يليه .... ويكون الترحيل من صفحة Main الى كل صفحة بداية من العمود B , والمسمى بـــ Voucher no. ويتم ملأ هذا العمود من العمود Z بصفحة Main ....أما العمود C والمسمى Cash فيتم ترحيل البيانات من صفحة Main والموجودة بالعمود AD اليه

أما العمود الأخير من الجدول بكل صفحة وهو العمود E والمسمى Remarks فيتم جلب بياناته من العمود M بصفحة Main ,,,,,أتمنى ان تكون الأمور بذلك واضحة بارك الله فيكم وزادكم الله من فضله

وهذا  Pdf هو شكل جدول من الجداول الموجودة بكل صفحة التى سوف يتم الترحيل اليها >>>كما انه موجود بصفحة Samir Fouad شكل البيانات المطلوب ترحيلها من صفحة Main كما تروا بالملف

Table.pdf

Master.xlsm

[خيماوي كووول]

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

تفضل اخوي العزيز .. تم وضع معادلة ..

يفضل اخوي العزيز .. تغيير عدد الشيتات .. الى شيت واحد فقط .. تم اضافة Data Validation .. ووضع الاسماء به .. قم باختيار الاسم فقط ..

 لجلب البيانات من الشيت main .. في حال تغيير الاسم سوف يجلب لك بيانات العميل الاخر .. وهكذا ..

Master.xlsm

[هانى محمد]

بارك الله فيك استاذى الكريم بالتأكيد معادلات ممتازة جعله الله فى ميزان حسناتك وغفر الله لك 

ولكن ياريت يكون الحل بالأكواد لأنى لدى أكثر من 40 اسم وأنا أريد ان يكون كل اسم بصفحة بحيث لو زادت البيانات عن الجداول الموجودة بالصفة يقوم الكود أيضاً بتصميم الجداول التى تكفى البيانات وسيتم بعد ذلك طباعة كل جداول اسم على حده فأنا لا أريد ان استمر أختار أكثر من 40 اسم من قائمة منسدلة فسيتم طباعة كل الجداول لكل الأسماء بكود واحد

رحم الله والديك وشاكر جداً لمجهودات حضرتك

[محي الدين ابو البشر]

لعل هذا ما ما يناسبك

فقط اشير أن الأرقام التسلسية في العمود A يجب ادخالها كأرقام وليس معادلة 1,2,3

وإذا كنت مصراً على المعادلات في العمود A   أخبرني

شكراً

مع الإعتذار

Sub test()
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp"
    For Each sh In Worksheets
        If sh.Name <> "Main" And sh.Name <> "Temp" Then
            With Sheets("Main")
                lr = .Cells(Rows.Count, 16).End(xlUp).Row + 1
                .Range("$A$2:$AQ$" & lr).AutoFilter Field:=16, Criteria1:=sh.Name
                Set rang = .Range("$A$2:$AQ$" & lr).SpecialCells(xlCellTypeVisible)
                rang.Copy Sheets("TEmp").Range("A1")
                .Cells.AutoFilter
                With Sheets("Temp")
                    a = .Cells(1, 1).CurrentRegion
                    .Cells(1, 1).CurrentRegion.ClearContents
                    a = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), Array(26, 30, "", 13))
                End With
                With sh
                    x = 1
                    For Each myArea In .Columns(1).SpecialCells(2, 1).Areas
                        n = myArea.Count
                        myArea.Offset(, 1).Resize(n, 4).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & _
                                                                                                                  x + n - 1 & ")"), Evaluate("column(" & [a1].Resize(, 4).Address & ")")), "")
                        x = x + n
                    Next
                End With
            End With
        End If
    Next
    Sheets("Main").Select
    Application.DisplayAlerts = flase
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Master (1).xlsm

[هانى محمد]

بارك الله فيك استاذ محي والمعذرة منك فقد أتعبتك كثيراً وهذا هو المطلوب بالفعل والكود الأن يعمل بكل كفاءة ولكن بشرط الترقيم داخل الجداول بالعمود A هل هناك امكانية فى عمل الكود بعد اضافة معادلات الترقيم السابقة بالعمود A , التى تم تواجدها بالملف الأول وهى ؟!وهل هذا الكود يمكنه نسخ جداول اضافية بالصفحات المرحل اليها اذا كانت البيانات المرحلة أكثر من الجداول الموجودة ؟ لأنه حتى ان وجدت الجداول بدون ترقيم للعمود A لا يتم ترحيل البيانات من قبل هذا الكود الا بالجداول التى بها ترقيم فقط !!!!

وبارك الله فيكم وفى جهودكم ورحم الله والديك

=IF($B8="","",SUBTOTAL(3,$B$8:B8))

Master 2.xlsm

[محي الدين ابو البشر]

تفضل أخي الكريم

معادلات في العمود A+إضافة صفحات في حال....,

Sub test()
    Application.ScreenUpdating = False
        ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp"
    For Each sh In Worksheets
        If sh.Name <> "Main" And sh.Name <> "Temp" Then
            With Sheets("Main")
                lr = .Cells(Rows.Count, 16).End(xlUp).Row + 1
                .Range("$A$2:$AQ$" & lr).AutoFilter Field:=16, Criteria1:=sh.Name
                Set rang = .Range("$A$2:$AQ$" & lr).SpecialCells(xlCellTypeVisible)
                rang.Copy Sheets("TEmp").Range("A1")
                .Cells.AutoFilter
                With Sheets("Temp")
                    a = .Cells(1, 1).CurrentRegion
                    .Cells(1, 1).CurrentRegion.ClearContents
                    a = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), Array(26, 30, "", 13))
                End With
                With sh
1                   lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
                    If lastrow / 41 < UBound(a) / 30 Then
                        Rows("1:41").Copy
                        Range("A" & lastrow + 2).Insert Shift:=xlDown
                        Application.CutCopyMode = False
                        GoTo 1
                    End If
                    For I = 8 To lastrow Step 41
                        Range("B" & I).Resize(30, 4).ClearContents
                    Next I
                    x = 1
                    For Each myArea In .Columns(2).Resize(, 5).SpecialCells(4, 1).Areas
                        n = myArea.Rows.Count
                        If n = 30 Then
                            myArea.Resize(n, 4).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & _
                                                                                                          x + n - 1 & ")"), Evaluate("column(" & [a1].Resize(, 4).Address & ")")), "")
                            x = x + n
                        End If

                    Next
                End With
            End With
        End If
    Next
    Sheets("Main").Select
    Application.DisplayAlerts = flase
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[محي الدين ابو البشر]

تفضل أخ الكريم

هناك مشكلة بدمج الخلايا مع الماكرو 

هناك بعض التعديلات على دمج الخلايا يرجى أخذها بعين الإعتبار 

لاحظ أيضاً أني تركت صفحة العميل الأول سمير.. عدد أقل من الصفحات

مشكلة إضافة شيت باسم عميل جديد لم تحل بعد، طبعاً يمكن حلها إذا أردت

Master.xlsm

[محي الدين ابو البشر]

أخبرتني العصفورة أن الموضوع تم حله ب Layout مختلف ومع ذلك بالنسبة لل الموجود هنا

إليك

Master (2).xlsm

[هانى محمد]

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