نقل البيانات الى ورقة عمل مستقلة

ابوسلماان · أبريل 28, 2021

الاعزاء الكرام ،، مساء الخير وشهر كريم على الجميع

مرفق لكم ملف اكسل فيه بيانات الرواتب ،، على أساس ان الصفوف تخص اسماء الموظفين، والاعمدة تخص بنود الراتب.

احتاج الى كود يقوم بنقل بيانات الموظف الى ورقة عمل أخرى بحيث يتكرر اسم الموظف اكثر من مرة في الصف ، وحسب عدد البنود التي فيها مبلغ يخصه.
فإذا كان الموظف لديه بند مثلا راتب اساسي ، بدل سكن ، اجمالي الاستحقاق ( هذه ثلاثةبنود )
فإن الموظف سينقل ويكرر ثلاث مرات في الصفوف، بحيث يكون مقابل كل اسم لهذا الموظف البند والمبلغ الخاص به.

ويقوم الكود بتخطي البنود التي ليس فيها مبالغ.

يوجد شرح في ملف الاكسل على اول موظف في الجدول، وكيفية نقله الى الورقة الجديدة.

آمل المساعدة ولكم خالص الامتنان ،، وفي حالة ان الشرح غير واف ،، آمل افادتي وشكراً

رواتب.xlsx

**سليم حاصبيا** · أبريل 29, 2021

جرب هذا الملف

1- القائمة المنسدلة في الخلية j2 ديناميكية
اي انها تستحيب لاي تغيير في الداتا مع عدم تكرار الاسماء

Option Explicit
'+++++++++++++++++++++++++++++++++++

Private Sub Worksheet_Activate()
DATA_VAL
End Sub
'++++++++++++++++++++++++++++++
Sub DATA_VAL()
Dim NT As Worksheet
Dim SA As Worksheet
Dim RON%, ROS%, i%
Set NT = Sheets("NEW_TABLE")
Set SA = Sheets("Salary")

Dim Dic As Object
ROS = SA.Cells(Rows.Count, 1).End(3).Row
 If ROS < 4 Then Exit Sub
 Set Dic = CreateObject("Scripting.Dictionary")
  For i = 4 To ROS
   If SA.Cells(i, 6) <> "" Then
    Dic(SA.Cells(i, 6).Value) = ""
   End If
   Next
   If Dic.Count Then
    With NT.Cells(2, "j").Validation
     .Delete
     .Add 3, Formula1:=Join(Dic.keys, ",")
    End With
    NT.Cells(2, "j").Value = Dic.keys()(0)
   End If
End Sub
'++++++++++++++++++++++++++++++++
Sub Fil_Data()
Dim Adr1%, Adr2%, X%, m%, k%, ROS%
Dim wat, Ro%
Dim Find_rg As Range
Dim Band As Range

Dim Bol As Boolean

Dim NT As Worksheet
Dim SA As Worksheet
Set NT = Sheets("NEW_TABLE")
Set SA = Sheets("Salary")
NT.Range("A2").CurrentRegion.Offset(1).Clear
If NT.Range("J2") = "" Then Exit Sub
wat = NT.Range("J2")
m = 3
  ROS = SA.Cells(Rows.Count, 6).End(3).Row
  '+++++++++++++++++++++++++++++++++++++++++
   With SA.Range("F3:F" & ROS)
        Set Find_rg = .Find(What:=wat, LookIn:=xlValues, lookat:=1)
        If Not Find_rg Is Nothing Then
            Adr1 = Find_rg.Row: Adr2 = Adr1
            Do
            NT.Range("A" & m).Resize(, 7).Value = _
            SA.Range("A" & Adr2).Resize(, 7).Value
              m = m + 1
            Set Find_rg = .FindNext(Find_rg)
            Adr2 = Find_rg.Row
            If Adr2 = Adr1 Then Exit Do
         
            Loop
        End If
    End With
   If m > 3 Then
   X = 3
    With SA.Range("F3:F" & ROS)
     Set Find_rg = .Find(What:=NT.Range("F3"), LookIn:=xlValues, lookat:=1)
      
        If Not Find_rg Is Nothing Then
            Adr1 = Find_rg.Row: Adr2 = Adr1
            Do
                Bol = False
                For k = 8 To 67
                    If SA.Cells(Adr2, k) <> "" Then
                    Bol = True
                    Exit For
                   End If
                  Next k
                If Bol Then
                  NT.Cells(X, "H") = SA.Cells(3, k)
                  X = X + 1
                End If
    
                Set Find_rg = .FindNext(Find_rg)
                Adr2 = Find_rg.Row
                If Adr2 = Adr1 Then Exit Do
         
            Loop
        End If
    End With
     With NT.Range("A3:H" & m - 1)
      .Font.Size = 14
      .Font.Bold = True
      .Borders.LineStyle = 1
      .InsertIndent 1
      .Interior.ColorIndex = 35
      End With
   End If
End Sub

النلف مرفق

RAWATEB.xlsm

ابوسلماان · أبريل 29, 2021

شكرا جزيلا باش مهندس سليم حاصبيا. الملف جدا رائع.

الان بعد المراجعة اتضح لي التالي:

- البنود لم تنتقل كلها. لو سحبت الى اخر البنود ستجد ان هناك بنود لم تقيد.

- المبالغ المرتبطة بالبنود ليست كما هي.

وايضا ،، لو حبيت احذف الفلتر كيف؟

**سليم حاصبيا** · أبريل 29, 2021

فقط امسح الخلية J2 واضغط الزر

ابوسلماان · أبريل 29, 2021

لاحظ معي الموظف الثاني مثلا.

Employee 5

البنود هي:

اجمالي الاستحقاق = 50000

رواتب فرع 4 = 30000

اجمالي الاستقطاع = 50000

عكس السيارات = 20000

-- باش مهندس عند حذف J2 لا يظهر اي موظف.

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

ابوسلماان · أبريل 29, 2021

السلام عليكم
تم اضافة ملف لتوضيح الفكرة بشكل افضل.

RAWATEB (1).xlsm

**ابراهيم الحداد** · أبريل 29, 2021

السلام عليكم ورحمة الله

اخى الكريم لقد فهمت من المشاركة الاولى انك تريد اضافة ورقة لكل

موظف ومن ثم اضافة البيانات التى تخصه فقط فى تلك الورقة

ان كان فهمى هذا صحيحا فيمكنك استخدام الكودين الاتيين

الاول لاضافة ورقة جديدة لاى موظف جديد

و الثانى لترحيل البيانات الخاصة به الى ورقته

اليك الكود الاول

يربط الزر الخاص بتنفيذ الكود بالكود الثانى

Sub CreateAcc()
Dim ws As Worksheet, Sh As Worksheet
Dim LR As Long, Rng As Range, C As Range
Set ws = Sheets("Salary04 (2)")
LR = ws.Range("F" & Rows.Count).End(3).Row
Set Rng = ws.Range("F3:F" & LR)
On Error Resume Next
For Each C In Rng
If Len(Trim(C.Value)) > 0 Then
If Len(Worksheets(C.Value).Name) = 0 Then
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value
End If
End If
With Sheets(C.Value)
.Range("A2:H2") = Array("التسلسل", "رقم المركز", "رقم الموظف", _
"الشهر", "السنة", "اسم الموظف", "البند", "المبلغ")
.Range("A2:H2").Font.Size = 14
.Range("A2:H2").Font.Bold = True
.Range("A2:H2").Columns.AutoFit
End With
Next
End Sub

الكود الثانى ويتم ربطه بالزر

Sub TrData()
Dim i As Long, wd As Worksheet
Dim C As Range, Sh As Worksheet
Set wd = Sheets("Salary04 (2)")
CreateAcc
For Each C In wd.Range("F3:F" & wd.Range("F" & Rows.Count).End(3).Row)
x = C.Row
i = 7
Do While i <= 100
If wd.Cells(x, i) <> "" Then
p = p + 1
With Sheets(C.Value)
.Cells(p + 2, 1) = wd.Cells(x, 1)
.Cells(p + 2, 2) = wd.Cells(x, 2)
.Cells(p + 2, 3) = wd.Cells(x, 3)
.Cells(p + 2, 4) = wd.Cells(x, 4)
.Cells(p + 2, 5) = wd.Cells(x, 5)
.Cells(p + 2, 6) = wd.Cells(x, 6)
.Cells(p + 2, 7) = wd.Cells(2, i)
.Cells(p + 2, 8) = wd.Cells(x, i)
.Range("A2:H" & p + 2).Columns.AutoFit
.Range("A2:H" & p + 2).Font.Bold = True
.Range("A2:H" & p + 2).Font.Size = 14
.Range("A2:H" & p + 2).Borders.LineStyle = 1
End With
End If
i = i + 1
Loop
p = 0
Next
End Sub

**سليم حاصبيا** · أبريل 30, 2021

اردت الاعتذار عن المتابعة بهذا الملف ااسبب التالي

في اول مشاركة لك من خلال العبارة التي كتبتها:

*** فإذا كان الموظف لديه بند مثلا راتب اساسي ، بدل سكن ، اجمالي الاستحقاق ( هذه ثلاثةبنود )
فإن الموظف سينقل ويكرر ثلاث مرات في الصفوف، بحيث يكون مقابل كل اسم لهذا الموظف البند والمبلغ الخاص به.

والان تريد

*** اسماء الموظفين في الصفوف لا يمكن تتكرر. بمعنى لا يمكن ان يتكرر اسم الموظف في اكثر من صف

لكن بما هي المرة الأولى تم التعديل على الماكرو لبعمل كما تريد

الماكرو الجديد (العمل في صفحة Salim )

Sub Enplyee_Data()
Dim Target_sheet As Worksheet
Dim SA As Worksheet
Dim RO%, ROS%, i%, n%
Dim How_many%, m%, t%, x%
Dim Data As Range
Dim Dic As Object, Ky
Dim arr_Band(), arr_Num()
Application.ScreenUpdating = False

Set Target_sheet = Sheets("Salim")
Set SA = Sheets("Salary")
RO = Target_sheet.Cells(Rows.Count, 1).End(3).Row
If RO > 2 Then
Target_sheet.Range("A3:H" & RO + 2).Clear
End If
ROS = SA.Cells(Rows.Count, 1).End(3).Row
   Set Dic = CreateObject("Scripting.Dictionary")
        For i = 4 To ROS
          If SA.Cells(i, 6) <> "" Then
           Dic(SA.Cells(i, 6).Value) = ""
          End If
        Next i
        
If Dic.Count Then
m = 3
 For Each Ky In Dic.keys
    n = Application.Match(Ky, SA.Range("f4:f" & ROS), 0) + 3
    How_many = Application.CountA(SA.Range("H" & n).Resize(, 60))
    Target_sheet.Range("A" & m).Resize(How_many, 6).Value = _
    SA.Range("a" & n).Resize(, 6).Value
    m = m + How_many + 1
 Next Ky
  For x = 3 To m - 2
   
   If Application.CountIf(Target_sheet.Range("F3:F" & x), Target_sheet.Range("F" & x)) = 1 Then
    n = Application.Match(Target_sheet.Range("F" & x), SA.Range("f4:f" & ROS), 0) + 3
    For y = 8 To 67
     If SA.Cells(n, y) <> "" Then
      ReDim Preserve arr_Band(t)
      arr_Band(t) = SA.Cells(3, y)
      ReDim Preserve arr_Num(t)
      arr_Num(t) = SA.Cells(n, y)
      t = t + 1
     End If
     Next y
   End If '<> ""
    If t > 0 Then
        Target_sheet.Range("G" & x).Resize(t) = _
        Application.Transpose(arr_Band)
        Target_sheet.Range("H" & x).Resize(t) = _
        Application.Transpose(arr_Num)
    End If 't>0
   t = 0: Erase arr_Num: Erase arr_Num
  Next x
End If
 RO = Target_sheet.Cells(Rows.Count, 1).End(3).Row
  t = 3
 If RO > 2 Then
   For n = 3 To RO + 1
    If Target_sheet.Cells(n, 1) = "" Then
    Target_sheet.Cells(n, "F") = "Sum Of " & Target_sheet.Cells(n - 1, "F")
    Target_sheet.Cells(n, "F").Resize(, 2).Merge
     Target_sheet.Cells(n, "H").Formula = _
     "=SUM(H" & t & ":H" & n - 1 & ")"
     t = n + 1
    End If
   Next
   Target_sheet.Cells(n, "F") = "Sum Of All "
     Target_sheet.Cells(n, "H").Formula = _
     "=SUM(H3:H" & n - 1 & ")/2"
     Target_sheet.Cells(n, "F").Resize(, 2).Merge
    With Target_sheet.Range("A3:H" & n)
      .Font.Size = 14
      .Font.Bold = True
      .Borders.LineStyle = 1
      .InsertIndent 1
      .Interior.ColorIndex = 35
      .Value = .Value
      .Columns(8).NumberFormat = "#,##0"
      End With
    For n = 3 To RO + 1
        If Target_sheet.Cells(n, 1) = "" Then
         Target_sheet.Cells(n, 1).Resize(, 8). _
         Interior.ColorIndex = 28
        End If
     Next
    Target_sheet.Cells(n, 1).Resize(, 8). _
    Interior.ColorIndex = 40
 End If
 Application.ScreenUpdating = True
End Sub
'++++++++++++++++++++++++++++++++

الملف مرفق

RAWATEB_ADVANCED.xlsm

ابوسلماان · أبريل 30, 2021

شكراً جزيلاً استاذ ابراهيم وجزاك الله كل خير

باش مهندس سليم ،، اولا اعتذر لك عن سوء التعبير عما يجب فعله، وثانيا اشكرك من اعماق قلبي على افادتي بالكود المطلوب وهذا ما اردته بالفعل.
وثالثا ،، لا نستغني ابدا عن خدماتكم وبارك الله فيكم وجزاكم الله خيرا.

تسجيل الدخول

نقل البيانات الى ورقة عمل مستقلة

الردود الموصى بها

ابوسلماان

رابط هذا التعليق

شارك

سليم حاصبيا

رابط هذا التعليق

شارك

ابوسلماان

رابط هذا التعليق

شارك

سليم حاصبيا

رابط هذا التعليق

شارك

ابوسلماان

رابط هذا التعليق

شارك

ابوسلماان

رابط هذا التعليق

شارك

ابراهيم الحداد

رابط هذا التعليق

شارك

سليم حاصبيا

رابط هذا التعليق

شارك

ابوسلماان

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information