تعديل على كود تجميع الشيتات ليكون حسب اختيار الشيت

[sabah2022]

السلام عليكم - عيدكم مبارك

ممكن التعديل على الكود ليصبح

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

مع تصميم كود لبيان اسماء الشيتات

كما موضوع في الملف شيت (تجميع)

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

تجميع.xlsm

[محمد هشام.]

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

ما عليك سوى تحديد الشيتات المرغوب دمجها كما في الصورة 

 

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 بواسطه محمد هشام.

[sabah2022]

الله يرضى عليك

تسلم

هو المطلوب

مشكور