ترحيل

[mohamedkaven]

عندى مجموعة من الموظفين فى شيت اكسل بالشكل التالى 

احمد محمود

محمود محمود

احمد محمود

واريد ترحيل بيانات الموظف احمد محمود فى شيت اخر بالشكل التالى 

احمد محمود

احمد محمود

وشيت اخر للموظف الاخر بالشكل التالى 

محمود محمود

كيف يمكننى عمل ذلك ؟

 

[حسين مامون]

اين الملف 

ارفع نمودج لملف العمل وضع البيانات كما تتوع ان تكون في النهاية 

[mohamedkaven]

test.xlsx

[حسين مامون]

على ما فهمت من طلبك تريد ترحيل بيانات كل موظف في شيت خاص به

[حسين مامون]

تفضل

test (2).xlsm

[mohamedkaven]

رائع 
تسلم ايدك 

 

[أحمد يوسف]

أستاذ

mohamedkaven

 

أين الضغط على الإعجاب ؟!!!!!!

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

بعد اذن الاخ حسين

1-هذا الكود يضيف لك Hypperlink من كل صفحة (في الخلية F1) الى الصفحة الرئيسية SALIM 

2-في حال تكرار الاسم الماكرو يتجاهل هذا الامر (دون رسالة خطأ)

3-كما يضيف لك حرية الانتقال الى الصفحة التي تريد من خلال الضغط على الاسم الذي تحتة خط في الصفحة SALIM

4-كل ما عليك هو تغيير اسم الشيت الاولى  الى SALIM  لحسن نسخ الكود ولصقة دون ظهور احرف و كلمات غير مفهومة في الكود

Option Explicit

Sub ADD_SH_with_Hyper()
'code to add Sheets One Time WITH HYPERLINKS
'Crated By Salim Hasbaya On 5/11/2019
Dim Rg As Range
Dim sh As Worksheet
Dim LA%, K%, i%, m%: m = 2
Dim x
Dim ws As Worksheet
Set sh = Sheets("SALIM")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.Name <> "SALIM" Then
          ws.Delete
        End If
    Next
 Application.DisplayAlerts = True
LA = sh.Cells(Rows.Count, 1).End(3).Row
For Each Rg In sh.Range("A2:A" & LA)
    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("F1"), Address:="", SubAddress:= _
              "SALIM!A1", TextToDisplay:="Goto SALIM"
             For K = 2 To LA
              If sh.Range("A" & K) = .Name Then
               .Cells(m, 2) = sh.Range("B" & K)
               m = m + 1
              End If
             Next K
             m = 2
         .Cells(1, 2) = .Name
         .Range("B:B,F:F").EntireColumn.AutoFit
     End With
        End If
      End If
Next Rg

With Sheets("SALIM")
    .Hyperlinks.Delete
 For i = 2 To LA
    x = Application.CountIf(sh.Range("A2:A" & i), sh.Range("A" & i))
    If x = 1 Then
    .Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", SubAddress:= _
    "'" & .Range("A" & i) & "'!A1", TextToDisplay:=.Range("A" & i).Value
    Else
    sh.Range("A" & i).Font.Underline = False
    End If
 Next
   .Select
   Application.ScreenUpdating = True
End With
End Sub

الملف مرفق للتجربة

 

Create_sheet_with Hyperlink.xlsm