ترحيل البيانات من اكثر من شيت الى شيت واحد

[ابومهندالخضري]

السلام عليكم

في الملف المرفق المطلوب ترحيل البيانات من الشيتات الثلاثة الاولى الى الشيت الرابع ويتم ترتيب البيانات حسب اسم الموظف بحيث لو حصل اي تغيير في الشيتات الثلاث الاولى يحصل التغيير في الشيت الرابع 

ترحيل بيانات.xlsx

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

قم بتغيير اسم الشيت  مجمل إلى Total  ونفذ هذا الكود

Option Explicit

Sub get_data()
Dim SH_from As Worksheet
Dim T As Worksheet
Dim Rt%, MY_max%, Ro%: Ro = 3

Set T = Sheets("Total")
Rt = T.Cells(Rows.Count, 2).End(3).Row
If Rt <= 2 Then Rt = 3
  
  With T.Range("B3").Resize(Rt, 5)
    .ClearContents
    .Interior.ColorIndex = xlNo
  End With

For Each SH_from In Sheets
    If SH_from.Name <> T.Name Then
      MY_max = Application.Max(SH_from.Range("A:A"))
      T.Cells(Ro, 2).Resize(MY_max, 5).Value = _
      SH_from.Cells(3, 2).Resize(MY_max, 5).Value
      
      With T.Cells(Ro + MY_max, 3)
        .Value = SH_from.Name
        .Offset(, -1).Resize(, 5).Interior.ColorIndex = 6
      End With
    Ro = Ro + MY_max + 1
End If

Next SH_from
End Sub

الملف مرفق

 

M_data.xlsm

[ابومهندالخضري]

شكرا اخ سليم حاصبيا عمل رائع جدا

ولكن عندي طلب هل يمكن حذف الصفوف الصفراء من الشيت Total   

ويتم ترتيب جميع الاسماء جميعها حسب الحروف الابجدية

مع جزيل تقديري لك اخي

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

تم معالجة الامر

ملاحظة يجب ترك الصف 2 في الشيت total فارغاً للحفاظ على بنية الجدول دون تدخل خلايا غريبة (بذلك تكون اول خلية بالجدول بعد الرأس هي الخلية A4)

Option Explicit

Sub get_data_New()
    Dim SH_from As Worksheet
    Dim T As Worksheet
    Dim rg_to_Patse As Range
    Dim Rt%, MY_max%, Ro%: Ro = 4
Set T = Sheets("Total")
Set rg_to_Patse = T.Range("A3").CurrentRegion
  Rt = rg_to_Patse.Rows.Count
   If Rt > 1 Then
    Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1)
    Else
     Set rg_to_Patse = T.Range("B4").Resize(, 5)
   End If
   rg_to_Patse.Clear
For Each SH_from In Sheets
    If SH_from.Name <> T.Name Then
      MY_max = Application.Max(SH_from.Range("A:A"))
      T.Cells(Ro, 2).Resize(MY_max, 5).Value = _
      SH_from.Cells(3, 2).Resize(MY_max, 5).Value
     Ro = Ro + MY_max
   End If
Next SH_from
  With T.Range("A3").CurrentRegion
    .Sort key1:=Range("b3"), Header:=1
    .Columns(1).Offset(1).Formula = _
       "=IF(B4="""","""",MAX($A$3:A3)+1)"
    .Offset(1).Borders.LineStyle = 1
    .Offset(1).InsertIndent 1
    .Value = .Value
    .Font.Bold = True
  End With
End Sub

 

M_data_new.xlsm

[ابومهندالخضري]

العمل رائع كصاحبه

احسنت وبارك الله بك 

سهل الله كل امورك كما سهلت امري

اكرر شكري وتقديري لك اخي 

لقد عملت على الكود وكان رائعا جدا ولكن عندي طلب اخر لاكمال عملي وساكون شاكرا فضلك

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

ثانيا : في شيت ال total  هل يمكن وضع الصفوف الملونة بلون غير الابيض في الاسفل وكما في الملف المرفق

مع كل التقدير لك اخي

ترحيل 11.xlsm

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

تم تحرير كود لهذا الغرض

Option Explicit

Sub MY_Data_New()

Application.ScreenUpdating = False
    Dim SH_from As Worksheet
    Dim T As Worksheet
    Dim rg_to_Patse As Range
    Dim Rt%, MY_max%, ro%: ro = 4
Set T = Sheets("Total")
Set rg_to_Patse = T.Range("A3").CurrentRegion
  Rt = rg_to_Patse.Rows.Count
   If Rt > 1 Then
    Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1)
    Else
     Set rg_to_Patse = T.Range("B4").Resize(, 5)
   End If
   rg_to_Patse.Clear
For Each SH_from In Sheets
    If SH_from.Name <> T.Name Then
      MY_max = Application.Max(SH_from.Range("A:A"))
      SH_from.Cells(3, 1).Resize(MY_max, 6).Copy
        With T.Cells(ro, 1)
         .PasteSpecial (xlPasteValues)
         .PasteSpecial (xlPasteFormats)
        End With
     ro = ro + MY_max
   End If
Next SH_from

With T.Range("A4").Resize(ro - 4, 6)
    .Sort key1:=Range("b3"), Header:=1
    .Value = .Value
End With
Application.ScreenUpdating = True
  arraNge_all
  
End Sub
'+++++++++++++++++++++++++++++++++++
Sub arraNge_all()
Application.ScreenUpdating = False
Dim nro%
Dim MM%
nro = Cells(Rows.Count, 1).End(3).Row
Dim color_rg As Range
For MM = 4 To nro
 If Range("a" & MM).Interior.ColorIndex <> xlNo Then
  If color_rg Is Nothing Then
   Set color_rg = Range("a" & MM).Resize(, 6)
   Else
  Set color_rg = Union(color_rg, Range("a" & MM).Resize(, 6))
  End If

 End If
 Next
 color_rg.Copy Range("a" & nro + 1)
 color_rg.EntireRow.Delete
  Range("A4", Range("A3").End(4)).Formula = _
  "=IF(B4="""","""",MAX($A$3:A3)+1)"
  Range("A3").CurrentRegion.Value = _
  Range("A3").CurrentRegion.Value
  Range("A4").Select
 Set color_rg = Nothing
 Application.ScreenUpdating = True
End Sub

الملف من جديد

M_data_new_SA.xlsm

[ابومهندالخضري]

السلام عليكم

لا اعرف كيف اقدم شكري وتقديري لك اخي الكريم لمجهودك هذا 

ولكني لم اعرف كيف اضع الكود في ملفي الذي تم تحويره حسب متطلباتي

الملف المرفق هو ملفي الذي غيرت فيه بعض الامور والمطلوب هو ان تنقل المعلومات الى الشيت الاخير Total بنفس التنسيق 

وكذلك تكون الاسماء متسلسلة حسب الحروف الابجدية

وتكون الخلايا الملونة في نهاية الجدول 

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

واعتذر للاطالة وشكرا لكل ما قمت به وبارك الله بك وجزاك الله خير الجزاء

اخير.xlsm

تم تعديل يناير 11, 2020 بواسطه ابومهندالخضري

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

تمت معالجة الامر

Option Explicit

Sub MY_Data_New()

Application.ScreenUpdating = False
    Dim SH_from As Worksheet
    Dim T As Worksheet
    Dim rg_to_Patse As Range
    Dim Rt%, MY_max%, ro%: ro = 4
Set T = Sheets("Total")
Set rg_to_Patse = T.Range("A3").CurrentRegion
  Rt = rg_to_Patse.Rows.Count
   If Rt > 1 Then
    Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1)
    Else
     Set rg_to_Patse = T.Range("B4").Resize(, 5)
   End If
   rg_to_Patse.Clear
For Each SH_from In Sheets
    If SH_from.Name <> T.Name Then
      MY_max = Application.Max(SH_from.Range("A:A"))
      SH_from.Cells(3, 1).Resize(MY_max, 6).Copy
        With T.Cells(ro, 1)
         .PasteSpecial (xlPasteValues)
         .PasteSpecial (xlPasteFormats)
        End With
     ro = ro + MY_max
   End If
Next SH_from

With T.Range("A3").Resize(ro - 4, 6)
    .Sort key1:=Range("b3"), Header:=1
End With
Application.ScreenUpdating = True
  arraNge_all
  
End Sub
'+++++++++++++++++++++++++++++++++++
Sub arraNge_all()
Application.ScreenUpdating = False
Dim nro%
Dim MM%
nro = Cells(Rows.Count, 1).End(3).Row
Dim color_rg As Range
For MM = 4 To nro
 If Range("B" & MM).Interior.ColorIndex = 2 Or _
  Range("B" & MM).Interior.ColorIndex = -4142 Then GoTo Next_MM
  If color_rg Is Nothing Then
   Set color_rg = Range("B" & MM).Resize(, 5)
   Else
   Set color_rg = Union(color_rg, Range("B" & MM).Resize(, 5))
  End If

Next_MM:
 Next

 If color_rg Is Nothing Then GoTo Contenu
 color_rg.Copy Range("B" & nro + 1)
 color_rg.EntireRow.Delete

Contenu:
  Range("B4", Range("B3").End(4)).Offset(, -1).Formula = _
  "=IF(B4="""","""",MAX($A$3:A3)+1)"
    With Range("A3").CurrentRegion
    .Value = .Value
    .Borders.LineStyle = 1
    End With
  Range("A4").Select
 Set color_rg = Nothing
 create_borders
 Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++++
Sub create_borders()
Dim My_sh As Worksheet, r
 For Each My_sh In Sheets
 If My_sh.Name <> "Total" Then
  r = My_sh.Cells(Rows.Count, 2).End(3).Row
  My_sh.Cells.Borders.LineStyle = xlNone
  My_sh.Range("a2").Resize(r - 1, 6).Borders.LineStyle = 1
End If
  Next
End Sub

الملف الأخير

Laste_flie.xlsm

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

بعد تنفيذ الماكرو الق نظرة على الشيتات ترى كل شيء قد تم كما تريد

[ابومهندالخضري]

فعلا اخي دققت ورايت كل شيء رائع

سلمت يداك على هذا العمل الرائع 

وجزاك الله افضل الجزاء

واعتذر للاطالة ولتعبك معي