محتاج كود تجميع شيتات

[2saad]

من فضلكم

عايزكود لتجميع الشيتات ( 1و2و3و4 وهناء و مني ) في شيت ( مجمع شيتات) مع الاحتفاظ بالشيتات الأخري

وياريت اسمي هذه الشيتات في الكود

 

 

 

 

ولكم جزيل الشكر ووافر الاحترام

وهذا رابط الملف لان حجمه كبير

https://www.mediafire.com/file/jdc5zs572x9nc9t/ايمن.xlsx/file

[أ / محمد صالح]

هل تقصد نسخ البيانات من الشيتات المحددة إلى شيت مجمع شيتات؟

وإذا كان هذا هو المقصود

فيمكنك استعمال هذا الكود

Sub getdata2()
Sheet1.Range("a3:o" & Sheet1.Cells(Rows.Count, 2).End(3).Row + 2).ClearContents
mysh = Array("1", "2", "3", "4", "هناء", "مني")
For Each n In mysh
lr = Sheets(n).Cells(Rows.Count, 2).End(3).Row
If lr > 2 Then
lr2 = Sheet1.Cells(Rows.Count, 2).End(3).Row + 1
lr2 = IIf(lr2 < 3, 3, lr2)
Sheet1.Range("b" & lr2 & ":o" & lr2 + lr - 3).Value = Sheets(n).Range("b3:o" & lr).Value
End If: Next n
Sheet1.Range("A3").Value = 1
Sheet1.Range("A3").AutoFill Destination:=Range("A3:A" & lr2 + lr - 3), Type:=xlFillSeries
Sheet1.Range("A3").Select
MsgBox "Done by mr-mas.com"
End Sub

الكود يقوم بنسخ بيانات الشيتات الموجودة في المصفوفة إلى شيت مجمع شيتات ويقوم بوضع مسلسل للكل

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

بالتوفيق

[عبدالفتاح في بي اكسيل]

هذه  محاولة على حسب  الشرح في  موضوعك  الاصلي على الرغم  من شح  المعلومات 

قم بنسخ رؤوس  العناوين اولا  قبل تنفيد  الكود 

Sub merge_sheets()
    Dim MUL As Variant
    Dim Ws As Worksheet
    MUL = Array("1", "2","3","4","مني","هناء" )
    For Each Ws In Worksheets(MUL)
        Ws.UsedRange.Offset(1).copy Sheets("مجمع شيتات").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Application.DisplayAlerts = False
        Application.DisplayAlerts = True
    Next Ws
    
End Sub

 

تم تعديل سبتمبر 17, 2021 بواسطه عبدالفتاح في بي اكسيل
خطأ مطبعي

[2saad]

شكرا جزيلا

[أ / محمد صالح]

الشكر لله الذي وفقنا