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

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

حياكم الله

يوجد كود من تصميم الاستاذ سليم المحترم

المطلوب - تخصيص الشيتات المراد تجميعها

جزيتم خيرا

تجميع الشيتات في شيت واحد - كود من تصميم استاذ سليم المحترم.xlsm

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

استبدل  الكود بهذا (هذا الكود يعمل اينما كانت الاوراق غير المرغوبة)

Option Explicit
 Sub Give_ALL_Data()
 Dim Arr_sh(), i%, m%: m = 2
 Dim Arr_counte(), k%: k = 1
 
  For i = 1 To Sheets.Count
       
      If InStr(Sheets(i).Name, "شهر") Then
          ReDim Preserve Arr_sh(1 To k)
          ReDim Preserve Arr_counte(1 To k)
          Arr_sh(k) = Sheets(i).Name
          Arr_counte(k) = Application.Max(Sheets(i).Range("a:a"))
          k = k + 1
      End If
  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

او استبدل في الكود القديم هذا السطر (شرط  وجود الاوراق غير المرغوبة في الأخر)

 

For i = 1 To Sheets.Count-1

بهذا

For i = 1 To Sheets.Count-3

الملف مرفق

Tajmi3.xlsm

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

جزيت خيرا

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

صحيح 100 %

 

[جمعة العوامي]