sabah2022 قام بنشر يونيو 30, 2023 مشاركة قام بنشر يونيو 30, 2023 السلام عليكم - عيدكم مبارك ممكن التعديل على الكود ليصبح يكون التجميع حسب اختيار الشيت مع تصميم كود لبيان اسماء الشيتات كما موضوع في الملف شيت (تجميع) جزاكم الله عنا خير - وكل عام وانتم بخير تجميع.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر يوليو 1, 2023 أفضل إجابة مشاركة قام بنشر يوليو 1, 2023 (معدل) وعليكم السلام ورحمة الله تعالى وبركاته ما عليك سوى تحديد الشيتات المرغوب دمجها كما في الصورة Sub Merge_worksheets() Dim Rng, C, A(), P&, i&, F&, Y&, N&, derligne&, lastrow& Dim DestArr() As String Dim ws As Worksheet: Set ws = Sheets("تجميع") lastrow = ws.Cells(Rows.Count, "a").End(xlUp).Row + 1 N = ws.Range("W" & Rows.Count).End(xlUp).Row Set Rng = ws.Range("W2:W" & N) Application.ScreenUpdating = False If ws.[V2] = Empty Then m = MsgBox("المرجوا تحديث قائمة أسماء الشيتات", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "انتباه"): Exit Sub On Error Resume Next For Each C In Rng If C Then If C <> "" Then ReDim Preserve DestArr(0 To P) DestArr(P) = C.Offset(, -1).Value P = P + 1 End If End If Next For K = LBound(DestArr) To UBound(DestArr) Worksheets(DestArr(K)).Activate derligne = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row Rng = ActiveSheet.Range("A5:N" & derligne) For i = 1 To UBound(Rng, 1) ws.Range("A2:N" & lastrow).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Rng, 2), 1 To Y) For F = 1 To UBound(Rng, 2) A(F, Y) = Rng(i, F) Next Next With ws ws.Range("a2").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next On Error GoTo 0 ws.Activate End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub ListSheets() Dim derligne&, x As Integer Dim ws As Worksheet: Set ws = Sheets("تجميع") derligne = ws.Cells(Rows.Count, 22).End(xlUp).Row + 1 Application.ScreenUpdating = False ws.Range("v2:v" & derligne).ClearContents x = 2 For Each WSdata In Worksheets If WSdata.Name <> ws.Name Then ws.Cells(x, 22) = WSdata.Name x = x + 1 End If Next End Sub تجميع V2.xlsm تم تعديل يوليو 1, 2023 بواسطه محمد هشام. 2 رابط هذا التعليق شارك More sharing options...
sabah2022 قام بنشر يوليو 1, 2023 الكاتب مشاركة قام بنشر يوليو 1, 2023 الله يرضى عليك تسلم هو المطلوب مشكور رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان