سؤال للعباقره بخصوص الهايبر لينك

[حواديت]

عندى شيت اسمها العملاء مجمع فيها اسماء العملاء كلها بنسب خصمهم

ينفع لما اضيف عميل جديد الاكسيل يعمل ادراج لصفحه جديد ببيانات العميل

[حواديت]

  في 19‏/11‏/2018 at 11:26, حواديت said:

عندى شيت اسمها العملاء مجمع فيها اسماء العملاء كلها بنسب خصمهم

ينفع لما اضيف عميل جديد الاكسيل يعمل ادراج لصفحه جديد ببيانات العميل

Expand  

مستنى ردكم درورى

[حواديت]

  في 19‏/11‏/2018 at 11:26, حواديت said:

عندى شيت اسمها العملاء مجمع فيها اسماء العملاء كلها بنسب خصمهم

ينفع لما اضيف عميل جديد الاكسيل يعمل ادراج لصفحه جديد ببيانات العميل

Expand  

مستنى ردكم درورى

مسحوبات.xlsx

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

جرب هذا الكود

Option Explicit

Sub creat_shett()
Dim i%, t, m%
Dim x%: x = Application.CountA(Sheets("Principal").Range("A:A")) + 1

For i = 3 To x

t = Sheets("Principal").Range("a" & i)
On Error Resume Next
m = Len(Sheets(t).Name)
On Error GoTo 0
   If m = 0 Then
'==========================================================='
   Sheets("Main").Copy After:=Sheets(Sheets.Count)
   With ActiveSheet
   .Name = Sheets("Principal").Range("a" & i)
   .Range("a1") = .Name
   End With
 '==========================================================='
  End If
  m = 0
    Next
  Sheets("Principal").Select
End Sub

الملف مرفق

مسحوبات.xlsm

[حواديت]

  في 19‏/11‏/2018 at 13:30, سليم حاصبيا said:

جرب هذا الكود

Option Explicit

Sub creat_shett()
Dim i%, t, m%
Dim x%: x = Application.CountA(Sheets("Principal").Range("A:A")) + 1

For i = 3 To x

t = Sheets("Principal").Range("a" & i)
On Error Resume Next
m = Len(Sheets(t).Name)
On Error GoTo 0
   If m = 0 Then
'==========================================================='
   Sheets("Main").Copy After:=Sheets(Sheets.Count)
   With ActiveSheet
   .Name = Sheets("Principal").Range("a" & i)
   .Range("a1") = .Name
   End With
 '==========================================================='
  End If
  m = 0
    Next
  Sheets("Principal").Select
End Sub

الملف مرفق

مسحوبات.xlsmFetching info...

Expand  

متشكر لزوقك تمام يا باشا