اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by حسونة حسين,

الردود الموصى بها

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

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

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

رابط هذا التعليق
شارك

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

الف تحية

  • Like 2
رابط هذا التعليق
شارك

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

ملف العمل هو 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

 

  • Like 4
رابط هذا التعليق
شارك

اخي الكريم 

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

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

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

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

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

FH (1).xlsx

رابط هذا التعليق
شارك

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

كود بسيط 

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

Application.ScreenUpdating = True

ضع هذه الاسطر 

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

 

  • Like 2
رابط هذا التعليق
شارك

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

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

 

  • Like 2
رابط هذا التعليق
شارك

  • 2 weeks later...

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

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

أريد توضيح أن شيت 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

 

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information