تعديل على كود تجميع الشيتات في شيت واحد مع نفس التنسيق

[خالد ابوعوف]

حياكم الله

تعديل على كود تجميع الشيتات في شيت واحد

تجميع الشيتات.xlsm

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

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

جرب هذا الكود

Option Explicit
 Sub Give_ALL_Data()
 Dim Arr_sh(), i%, m%: m = 2
 Dim Arr_counte()
 
  For i = 1 To Sheets.Count - 1
          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("تجميع").Range("b2:i500").ClearContents
   For i = LBound(Arr_sh) To UBound(Arr_sh)
     Sheets("تجميع").Range("b" & m).Resize(Arr_counte(i), 8).Value = _
     Sheets(Arr_sh(i)).Range("b2").Resize(Arr_counte(i), 8).Value
      m = m + Arr_counte(i) + 1
    Next
Erase Arr_sh: Erase Arr_counte
End Sub

الملف مرفق

 

Data_from_all_sheets.xlsm

[خالد ابوعوف]

حياك الله - استاذنا

جزيت خيرا

وجدت هذا الكود في الارشيف حاسبتي - ولم أعلم لمن 

ان شاء الله راح انتبه لهذه الامانة

استاذنا :

ممكن تسمية الشيتات التي اريد جمعها في الكود

لانه هناك شيتات لا اريد جمعها ، سبق وان حذفتها - مثل شيت (قائمة استدعاء بيناتان ) و (قائمة اسماء الادارة )

 

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

ممكن جمع الشيتات التي تريد في Array والتعديل في الكود كما تشاء

[خالد ابوعوف]

ممكن اجراء عملية واحدة وعلى اساسها اكمل - في اضافة الشيتات المختارة