تجميع بيانات شيتات إلى شيت رئيسي

[مداد_1423]

تحية طيبة للجميع 

بداية أشكر كل من في هذا المنتدى الذي استفدت منه كثيرا

أشكر الأستاذ: ياسر خليل أبو البراء

على كود دمج الملفات في ملف واحد والذي أخذته من هذا الموضوع

والكود يعمل بكفاءة عالية ،

المطلوب : 1) قبل الدمج تحذف جميع الشيتات ما عدى أول وثاني شيت

2) تعديل الكود بحيث يجمع فقط شيت Overtime فقط وليس كل الشيتات

 

====

ثانياً: أشكر الأستاذسليم حاصبيا

على كود تجميع البيانات من شيتات إلى شيت واحد في هذه المشاركة

المطلوب:

1) حذف بيانات شيت ALL من A3:AF1000 كما في الصورة

 

2) تجميع بيانات الشيت من A8 إلى آخر خلية فيها بيانات من نفس العامود إلى العامود AG باستثناء العامود B لا أريد أن يكون في التجميع

صورة توضيحية

 

أتمنى ما يكون طلبي ثقيل على حضراتكم

مع الشكر لكل من مر هنا ، وأخص بالشكر والدعاء من ساعدني

والله يقدرنا على رد فضلكم علينا

وهنيئا لصاحب العلم زكاة علمه

 

تحياتي

 

 

TO_Officena.rar

[سليم حاصبيا]

جرب هذا الماكرو بالنسبة للملفات HR_test

Option Explicit

Sub copy_data()
Dim S As Worksheet: Set S = Sheets("Shift Schedule")
Dim O As Worksheet: Set O = Sheets("Overtime")
Dim A As Worksheet: Set A = Sheets("Attendance")
Dim Final_S: Final_S = S.Cells(Rows.Count, 1).End(3).Row
Dim Final_O: Final_O = O.Cells(Rows.Count, 1).End(3).Row
Dim Final_A: Final_A = A.Cells(Rows.Count, 1).End(3).Row
Dim Rs As Range: Set Rs = S.Range("A8:AG" & Final_S)
Dim RO As Range: Set RO = O.Range("A8:AG" & Final_O)
Dim RA As Range: Set RA = A.Range("A8:AG" & Final_A)
Dim i%, xO%, XA%, xx%
xO = RO.Rows.Count: XA = RA.Rows.Count
Rs.ClearContents
i = 1: xx = 8
Do Until i > xO
  S.Cells(xx, 1) = RO.Cells(i, 1)
  S.Cells(xx, 3).Resize(, RO.Columns.Count - 2).Value = _
  RO.Cells(i, 3).Resize(, RO.Columns.Count - 2).Value
 i = i + 1: xx = xx + 2
Loop
i = 1: xx = 9
Do Until i > XA
  S.Cells(xx, 1) = RA.Cells(i, 1)
  S.Cells(xx, 3).Resize(, RA.Columns.Count - 2).Value = _
  RA.Cells(i, 3).Resize(, RA.Columns.Count - 2).Value
 i = i + 1: xx = xx + 2
Loop

End Sub

الملف مرفق

Salim_TEST3.xlsm

[مداد_1423]

ويرزقكم من حيث لا تعلمون

مع أن طلبي مختلف عن الكود تماما

إلا أن هذا الكود ينفعني كثيرا

واستحيت أطلبه من حضراتكم لأني توقعت بناء الكود صعباً

ألف ألف شكر وتقدير لك أستاذي سليم على الكود الرائع

 

وما زلت أنتظر تعديل الكود في المرفق في المشاركة الأساسية على حسب ما هو موضح بالصور

 

تحياتي لشخصك الكريم

[مداد_1423]

بحمد الله تمكنت من التعديل على الكود الأول (تجميع شيت من عدة ملفات في فولدر)

والكود يعمل بكفاءة عالية ولله الحمد

Sub CollectWorkbooks()
    Dim Path As String
    Dim Filename As String
    Dim SH As Worksheet
    Dim X As Long
    X = 2
    Path = ThisWorkbook.Path & "\Files\"
    Filename = Dir(Path & "*.xlsm")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        For Each SH In ThisWorkbook.Sheets
            If SH.Name <> "Nep_HR" And SH.Name <> "ALL" Then SH.Delete
        Next SH
        Do While Filename <> ""
            Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
                For Each SH In ActiveWorkbook.Sheets
                    If SH.Name <> "Overtime" Then GoTo 1
                    SH.Copy After:=ThisWorkbook.Sheets(X)
                    X = X + 1
1               Next SH
            Workbooks(Filename).Close
            Filename = Dir()
        Loop
    Sheets("Nep_HR").Activate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

بقي التعديل على الكود الثاني 

وهو تجميع بيانات ملف في شيت واحد

 

 

 

تجمع البيانات في شيت ALL بدءًا من الخلية A3

بحيث بيانات العامود A من الشيتات الأخرى تكون في العامود A

والعامود C من الشيتات الأخرى تكون في العامود B

 

 

 

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

 

 Sub Give_ALL_Data()
 Dim Arr_sh(), i%, m%: m = 2
 Dim Arr_counte()
 
  For i = 1 To Sheets.Count - 3
          ReDim Preserve Arr_sh(1 To i)
          ReDim Preserve Arr_counte(1 To i)
      Arr_sh(i) = Sheets(i).Name
      Arr_counte(i) = Application.Max(Sheets(i).Range("a:a"))
  Next
  Sheets("ALL").Range("A3:AG1000").ClearContents
   For i = LBound(Arr_sh) To UBound(Arr_sh)
     Sheets("ALL").Range("A" & m).Resize(Arr_counte(i), 8).Value = _
     Sheets(Arr_sh(i)).Range("A3").Resize(Arr_counte(i), 8).Value
      m = m + Arr_counte(i) + 1
    Next
Erase Arr_sh: Erase Arr_counte
End Sub

ملاحظة : فولدر فايل في المشاركة الرئيسية لمن أراد أن يستفيد من تجميع شيت من عدة ملفات

TEST__HR.xlsm

[مداد_1423]

تحية طيبة مباركة للجميع

أدام الله عليكم لباس الصحة جميعا

 

وجدت كود للأستاذ سليم حاصبيا لتجميع البيانات من الشيتات إلى شيت رئيسي وهو كود رائع وسريع

لكن ما قدرت أعدل عليه حتى يعمل مع الملف عندي

الكود:

 

 Sub Give_ALL_Data()
 Dim Arr_sh(), i%, m%: m = 2
 Dim Arr_counte()
 
  For i = 1 To Sheets.Count - 3
          ReDim Preserve Arr_sh(1 To i)
          ReDim Preserve Arr_counte(1 To i)
      Arr_sh(i) = Sheets(i).Name
      Arr_counte(i) = Application.Max(Sheets(i).Range("a:a"))
  Next
  Sheets("ALL").Range("A3:AH1000").ClearContents
   For i = LBound(Arr_sh) To UBound(Arr_sh)
     Sheets("ALL").Range("A" & m).Resize(Arr_counte(i), 8).Value = _
     Sheets(Arr_sh(i)).Range("A3").Resize(Arr_counte(i), 8).Value
      m = m + Arr_counte(i) + 1
    Next
Erase Arr_sh: Erase Arr_counte
End Sub

 

المطلوب تختصره الصورتين

أولاً:

 

 

ثانياً:

 

لكل من مر من هنا تحية 

ولكل من ساعدني دعوة خالصة وشكرا من الأعماق

تحياتي

TEST_ _HR.xlsm