كود تجميع كل البيانات لكل الشيتات الموجودة ماعدا ٣ شيتات معينة بنفس التنسيقات

[Ahmed Hanafi141995]

لدي ملف excel يحتوي علي اكثر من شيت ويتم اضافة شيت كل يوم . مطلوب اذا تكرمتم 

كود يقوم بتجميع كل البيانات لكل الشيتات الموجودة ماعدا ٣ شيتات معينة . علي ان يتم تجميع البيانات بنفس تنسيقها  ويتم تجميعها في ملف منفصل وليس في ملف العمل 

عنوان مخالف ... تـــم تعديل عنوان المشاركة ليعبر عن طلبك , انتبه لذلك من فضلك

[حسين مامون]

ارفع نمودج يحاكي الملف الرئيسي واذكر اسماء الشيتات التي ستستثنى من التجميع  والاخر الذي ستجمع فيه البيانات مع وضع بعض البيانات كما تتوقعها

الف تحية

[Ahmed Hanafi141995]

شكرا لك اخي الكريم 

ملف العمل هو reel data 

الثلاث ملفات المستثناه summery . Time.Hold

النتيجة المراد الوصول اليها هو الملف باسم AHMED

مع العلم اخي الكريم انه يتم اضافة كل يوم شيت اضافي

 

AHMED.xlsx REEL DATA OF NOVEMBER 2021.xlsx

[حسونة حسين]

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

ضع هذا الكود في ملفك وشغله ستجد ملف باسم ملف REEL_DATA_OF_NOVEMBER_2021.Xlsb بجوار ملفك

Sub Total()
Dim ws  As Worksheet, temp As Variant, arr As Variant, F As Boolean, lr As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Total" And ws.Name <> "SUMMARY" And ws.Name <> "TIME" And ws.Name <> "HOLD" Then
            temp = ws.Range("A6:S" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Value2
            If F Then
                Dim I As Long, ii As Long, ub As Long
                ub = UBound(arr, 1)
                arr = Application.Transpose(arr)
                ReDim Preserve arr(1 To UBound(arr, 1), 1 To ub + UBound(temp, 1))
                arr = Application.Transpose(arr)
                For I = LBound(temp, 1) To UBound(temp, 1)
                    For ii = 1 To UBound(temp, 2)
                        arr(ub + I, ii) = temp(I, ii)
                    Next ii
                Next I
            Else
                arr = temp
                F = True
            End If
        End If
    Next ws
    
    If Not Evaluate("isref('" & "Total" & "'!A1)") Then Sheets.Add.Name = "Total"

    With Sheets("Total")
        .Range("A2:S65536").ClearContents
        .Range("A1").Resize(1, 19).Value = Array("V", "HH", "J", "K", "L", "DD", "HH", "K", "L", "P", _
                                                "GG", "S", "DF", "GH", "HJ", "KJ", "FGH", "G", "Remarks")
        .Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
        With .Range("A1:S" & .Cells(Rows.Count, 2).End(xlUp).Row)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .RowHeight = 15
            ActiveWindow.Zoom = 75
            .EntireColumn.AutoFit
            .Borders.Value = 1
        End With
    End With
    ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "REEL_DATA_OF_NOVEMBER_2021", FileFormat:=xlExcel12
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

 

[Ahmed Hanafi141995]

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

[حسونة حسين]

وجزاكم مثله اخى الكريم 

والحمد لله الذي بنعمته تتم الصالحات 

[Ahmed Hanafi141995]

اخي الكريم 

عند تجربة الكود تبين وجود أمرين غير مرغوب فيهم

١. البيانات ليست بنفس التنسيق.

٢.البيانات بعد التجميع ليست في ملف منفصل .

الملف المرفق يحتوي علي شيت واحد ويحتوي علي زر . انا اريد عند الضغط علي الزر .يتم تجميع البيانات في نفس صفحة الزر . 

ولك جزيل الشكر اخي الكريم

FH (1).xlsx

[حسونة حسين]

اخى الكريم لجعل ملف التجميع منفصل

كود بسيط 

قبل هذا السطر في الكود 

Application.ScreenUpdating = True

ضع هذه الاسطر 

Sheets("Total").Move
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Total.xlsb", FileFormat:=xlExcel12
    

 

[حسونة حسين]

وكود اخر اخى الكريم بدون مصفوفات

Sub Total()
Dim ws  As Worksheet, SH As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

If Not Evaluate("isref('" & "Total" & "'!A1)") Then Sheets.Add.Name = "Total"
    Set SH = ThisWorkbook.Worksheets("Total")
    SH.Range("A1").Resize(1, 19).Value = Array("V", "HH", "J", "K", "L", "DD", "HH", "K", "L", "P", _
    "GG", "S", "DF", "GH", "HJ", "KJ", "FGH", "G", "Remarks")
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Total" And ws.Name <> "SUMMARY" And ws.Name <> "TIME" And ws.Name <> "HOLD" Then
            'كود للنسخ العادي بدون مصفوفات ويجلب لك نفس تنسيق البيانات الاصليه
            ws.Range("A6:S" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Copy _
            SH.Range("A" & SH.Cells(Rows.Count, 2).End(xlUp).Row + 1)
            
        End If
    Next ws
    SH.Range("A1:S" & SH.Cells(Rows.Count, 2).End(xlUp).Row).EntireColumn.AutoFit
    Sheets("Total").Move
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Total.xlsb", FileFormat:=xlExcel12

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
End Sub

 

[Ahmed Hanafi141995]

شكرا جزيلا لك أخي الكريم . أدام الله عليك علمك وجعله في ميزان حسناتك . 💗💖💗

[حسونة حسين]

وجزاكم مثله اخى الكريم 

آمين يارب العالمين وإياكم 

[Ahmed Hanafi141995]

أخي في الله أسف علي الإطاله 

أريد تعديل بسيط في الكود ( الكود بدون مصفوفات )

أريد توضيح أن شيت real data يقوم شخص يوميا بإضافة اليوم وإرساله لي . فأنا لا أريد أن أضع الكود كل يوم في الشيت .

ما أريده أن يكون لي ملف ثابت عندي يكون إسمه total ويحتوي في الأعلي علي زر عند الضغط علي الزر يقوم بتنفيذ الكود علي ملف real data 

الملف المرفق هو النتيجة المراد التوصل إليها

ولكم جزيل الشكر

 

Total.xlsx

[حسونة حسين]

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

1- اجعل الملف الذي اسمه real data.xlsx بجوار الملف الذي اسمه (Total.xlsx )

الكود سوف يحذفه ووضع مكانه ملف باسم (Total.xlsb )

2- انسخ الكود التالي

3- اربط  الزر قي صفحة ( total  ) بالكود الذي اسمه ( total  )

4- ثم اضغط على الزر

5- سوف يعمل الكود ويجلب البيانات الموجوده في جميع الشيتات ماعدا ٣ شيتات معينة  وهما ( summery  )  (Hold ) (Time )

 

Sub Total()
    Dim WS As Worksheet, WB As Workbook, SH As Worksheet
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Set SH = ThisWorkbook.Worksheets("Total")
    Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "real data.xlsx", False)
        For Each WS In WB.Worksheets
            If WS.Name <> "Total" And WS.Name <> "SUMMARY" And WS.Name <> "TIME" And WS.Name <> "HOLD" Then
                WS.Range("A6:S" & WS.Cells(Rows.Count, 2).End(xlUp).Row).Copy _
                SH.Range("A" & SH.Cells(Rows.Count, 2).End(xlUp).Row + 1)
            End If
        Next WS
    WB.Close Savechanges:=True
    SH.Columns.AutoFit
    ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "Total", FileFormat:=xlExcel12
    On Error Resume Next
    Kill ThisWorkbook.Path & "\" & "Total.xlsx"
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

 

[Ahmed Hanafi141995]

شكرا جزيلا أخي الكريم وبارك الله لك

[حسونة حسين]

وجزاكم مثله اخى الكريم