مطلوب كود يبحث في اسامي الشيتات ويقارنها بخلايا

[gamalin]

الاخوة الافاضل 

لدي الملف المرفق به كود يقوم بتخليق شيتات وتغيير اسمها ليطابق ماهو موجود بالعمود B 

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

هل يمكن تعديل الكود ليبحث في الشيتات الموجودة ان وجد نفس الاسم في الخليه ب يتجاوزها للخلية الاحقه 

والا ينشئ الصفحة و يسميها بالاسم المطابق للخلية في B

officena.rar

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

جرب هذا الكود

Option Explicit
Sub Salim_Add_Sheets()
  
  Dim ERow01 As Long
  Dim arr_sheet(), my_name$
  Dim x%, y$, How_Many%, k%, i%
 
   ERow01 = Sheets("all").Range("a3").CurrentRegion.Rows.Count
    On Error Resume Next
  k = 1
    For i = 4 To ERow01
     How_Many = Application.CountIf(Sheets("all").Range("b4" & ":b" & i), Sheets("all").Range("b" & i))

If How_Many = 1 Then
 ReDim Preserve arr_sheet(1 To k)
 arr_sheet(k) = Sheets("all").Range("b" & i)
 k = k + 1
 End If
 Next
 For i = 1 To UBound(arr_sheet)
   my_name = Sheets(arr_sheet(i)).Name
   x = Len(my_name)
   If x = 0 Then
   Sheets("statment").Copy Before:=Sheets("statment")
   ActiveSheet.Name = arr_sheet(i)
   End If
   Next
Erase arr_sheet
  End Sub

 

[gamalin]

الخي الفاضل اشكرك لاستجابتك و جهدك الرائع والكود يعمل بكفاءة لولا انه عند تشغيله اول مرة يقوم فعلا بانشاء الصفحات المطلوبة فقط ولكن في حال وجود شيتات ( صفحات سابقة ) و اريد اضافة الصفحة الناقصة فقط لا يعمل اطلاقا 

توضيح حذفت صفحة من الصفحات التي انشاها وشغلت الكود فلم يحدث اي جديد هل يمكن ان يقوم بانشاء الصفحة الناقصة فقط 

ومرة اخرى اشكرك اخي الكريم

ولو امكن تفضلا منك كتابة شرح لهذا الكود اكون شاكر خاصة بعض الاسطر المبهمة نسبيا بالنسبة لي مثل 

  Dim x%, y$, How_Many%, k%, i%

 ReDim Preserve arr_sheet(1 To k)
 arr_sheet(k) = Sheets("all").Range("b" & i)

 

 For i = 1 To UBound(arr_sheet)

 

Erase arr_sheet

تم تعديل أكتوبر 27, 2017 بواسطه gamalin