كود ترحيل بيانات المرتبات حسب الكود الخاص

[جون ايمن]

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

البيانات والمطلوب بالتفصيل فى الشيت المرفق 

واشكركم جزيلا لانى اعلم انكم اهل خبرة

ترحيل.xlsx

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

جرب هذا الملف

الكود

Option Explicit
Sub From_sheet_to_Form()
 With Sheets("Salim")
 If .Range("N6") = vbNullString Then Exit Sub
    .[P8] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,2,0)")
    .[N8] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,3,0)")
    .[P10] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,4,0)")
    .[N10] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,5,0)")
    .[Q12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,6,0)")
    .[O12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,7,0)")
    .[M12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,8,0)")
End With

End Sub
'+++++++++++++++++++++++++++++++++++++++
Sub add_to_data_val()
 Dim arr(), m%, i%, lr%
 Dim s As Worksheet
 Set s = Sheets("Salim")
 lr = s.Cells(Rows.Count, 1).End(3).Row
 i = 2: m = 1
  Do Until i = lr + 1
   If Application.CountIf(s.Range("A2:A" & i), s.Range("A" & i)) = 1 Then
     ReDim Preserve arr(1 To m)
     arr(m) = s.Range("A" & i)
     m = m + 1
     End If
 i = i + 1
 Loop
  ReDim Preserve arr(1 To m)
  arr(m) = s.Range("N6")
 With s.Range("N6").Validation
  .Delete
  .Add 3, Formula1:=Join(arr, ",")
  End With
  s.Range("A" & lr + 1) = arr(UBound(arr))
  s.Range("N6") = arr(UBound(arr))

End Sub
'++++++++++++++++++++++++++++++++++++++++++++
Sub Form_To_sheet()
 Dim s As Worksheet
 Dim rg As Range, RO%
 Dim lr%, Answer As Byte
 Set s = Sheets("Salim")
 lr = s.Cells(Rows.Count, 1).End(3).Row
  If Application.CountIf(s.Range("A2:A" & lr), s.Range("N6")) = 0 Then
    Answer = MsgBox("This code dosn't exixts!.. " & Chr(10) & _
     "Do you like to add it", 4)
     If Answer = 6 Then
          add_to_data_val
      Exit Sub
    End If
  End If

  Set rg = s.Range("A1:A" & lr).Find(s.[N6], lookat:=1)
  If rg Is Nothing Then Exit Sub
   RO = rg.Row
 With s
 .Range("A" & RO) = .[N6]: .Range("B" & RO) = .[P8]
 .Range("C" & RO) = .[N8]: .Range("D" & RO) = .[P10]
 .Range("E" & RO) = .[N10]: .Range("G" & RO) = .[Q12]
 .Range("H" & RO) = .[O12]: .Range("I" & RO) = .[M12]
 End With
End Sub

الملف مرفق

 

Vice_versa.xlsm

[جون ايمن]

شكرا على الكود الممتاز 

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

ولا اساسية 

ولا ده عيب عندى

وسؤال اخر ما فائدة زر 

TO FORM- TO SHEET

وشكرا على المجهود الممتاز

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

TO FORM- TO SHEET ينقلان ما في الشيت الى الفورم وبالعكس بالضغط على الزر المناسب