كود انشاء صفحات حسب اسماء الموظفين

[ابو هاله النبلسي]

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

اشعار.rar

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

جرب هذا الماكرو  (تسمية اول شيت بـــ  Salim)

تم التقليل من عدد الصفوف لمراقبة عمل الماكرو

(يمكنك اضافة اي عدد من الصفوف ثم الضغط على الزر   Add Hypers )

Option Explicit

Sub ADD_S_with_Hyper()
'code to add Sheets One Time WITH HYPERLINKS
'Crated By Salim Hasbaya On 17/03/2020
Dim Rg As Range
Dim S As Worksheet
Dim LB%, K%, i%
Dim x
Dim ws As Worksheet
Set S = Sheets("Salim")
Application.ScreenUpdating = False

LB = S.Cells(Rows.Count, 2).End(3).Row
For Each Rg In S.Range("B8:B" & LB)
    If Rg.Value <> "" Then
        If Not Application.Evaluate("ISREF('" & Rg.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = Rg.Value
      With ActiveSheet
            .Hyperlinks.Add Anchor:=.Range("D1"), Address:="", SubAddress:= _
              "SALIM!B2", TextToDisplay:="Goto SALIM"
              .Name = Rg
              .Cells(1, 1) = Rg
              .Columns("A:A").AutoFit
              .Columns("D:D").AutoFit
     End With
        End If
      End If
Next Rg

With Sheets("Salim")
    .Hyperlinks.Delete
 For i = 8 To LB
    x = Application.CountIf(S.Range("B2:B" & i), S.Range("B" & i))
    If x = 1 Then
    .Hyperlinks.Add Anchor:=.Range("B" & i), Address:="", SubAddress:= _
    "'" & .Range("B" & i) & "'!B1", TextToDisplay:=.Range("B" & i).Value
    S.Range("B" & i).Font.Underline = False
    S.Range("B" & i).Font.Size = 16
    Else
    S.Range("B" & i).Font.Underline = False
    S.Range("B" & i).Font.Size = 16
    End If
 Next
   .Select
   With S.Range("b8:b" & LB)
   .HorizontalAlignment = 1: .Font.ColorIndex = 1
   .Font.Bold = -1: .InsertIndent 1
   .Borders.LineStyle = 1
   End With
   Application.ScreenUpdating = True
End With
End Sub

الملف مرفق

 

ISHAAR.xlsm

[ابو هاله النبلسي]

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

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

عند اذن يجب استعمال هذا الماكرو

Option Explicit

Sub ADD_S_with_Hyper()
'code to add Sheets One Time WITH HYPERLINKS
'Crated By Salim Hasbaya On 17/03/2020
Dim rg As Range, Rg_copy As Range
Dim Title_rg As Range, Past_rg As Range
Dim S As Worksheet
Dim LB%, K%, i%
Dim x
Dim ws As Worksheet
Set S = Sheets("Salim")
Set Title_rg = S.Range("a6").Resize(2, 67)

Application.ScreenUpdating = False

LB = S.Cells(Rows.Count, 2).End(3).Row
For Each rg In S.Range("B8:B" & LB)
    If rg.Value <> "" Then
        If Not Application.Evaluate("ISREF('" & rg.Value & "'!A1)") Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = rg.Value
      With ActiveSheet
            .Hyperlinks.Add Anchor:=.Range("D1"), Address:="", SubAddress:= _
              "SALIM!B2", TextToDisplay:="Goto SALIM"
              .Cells(1, 2) = rg
              .Columns("A:A").AutoFit
              .Columns("D:D").AutoFit
     End With
        End If
      End If
Next rg

With Sheets("Salim")
    .Hyperlinks.Delete
 For i = 8 To LB
    x = Application.CountIf(S.Range("B2:B" & i), S.Range("B" & i))
    If x = 1 Then
    .Hyperlinks.Add Anchor:=.Range("B" & i), Address:="", SubAddress:= _
    "'" & .Range("B" & i) & "'!B1", TextToDisplay:=.Range("B" & i).Value
    S.Range("B" & i).Font.Underline = False
    S.Range("B" & i).Font.Size = 16
    Else
    S.Range("B" & i).Font.Underline = False
    S.Range("B" & i).Font.Size = 16
    End If
 Next
   .Select
   With S.Range("b8:b" & LB)
   .HorizontalAlignment = 1: .Font.ColorIndex = 1
   .Font.Bold = -1: .InsertIndent 1
   .Borders.LineStyle = 1
   End With
   
  For i = 8 To LB
   Set ws = Sheets(S.Range("B" & i) & "")
   Title_rg.Copy
   ws.Range("a6").PasteSpecial
   Set Rg_copy = S.Range("A" & i)
   Set Past_rg = ws.Range("A8")
      Call give_data(Rg_copy, Past_rg, 67)
      Application.CutCopyMode = False
  Next
    Application.ScreenUpdating = True
End With
End Sub
'++++++++++++++++++++++++++++++++

Sub give_data(S_rg As Range, Target_rg As Range, n As Integer)
S_rg.Resize(, n).Copy
Target_rg.PasteSpecial
Target_rg.Offset(, 1).Resize(, n - 1).Columns.AutoFit
End Sub

الملف من جديد

ISHAAR_2.xlsm

[ابو هاله النبلسي]

احسنت وبارك الله فيك استاذ ورحم الله والديك عندي طلب اخير في البرنامج لكي يتم انه عند اختيار استقطاع (4) من الصف يظهر لي بصفحة منفصله مع كل الموظفين الذين لديهم بيانات في استقطاع (4) وهكذا لبقية الصف لطفا وشكرا لك مقدما

[ابو هاله النبلسي]

@سليم حاصبيا

عند اختيار استقطاع (4) من الصف في Salim يظهر لي بصفحة منفصله مع كل الموظفين الذين لديهم بيانات في استقطاع (4) وهكذا لبقية الصف لطفا وشكرا لك مقدما

[أحمد يوسف]

 أستاذ ابو عبد الرحمن العراقي

أين الضغط على الإعجاب لكل هذه الأكواد الممتازة ؟!!💙