اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

السلام عليكم

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

ترحيل بيانات.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

  • Like 3
  • Thanks 1
رابط هذا التعليق
شارك

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

ولكن عندي طلب هل يمكن حذف الصفوف الصفراء من الشيت 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

  • Like 3
  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

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

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

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

ثانيا : في شيت ال 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

  • Like 2
  • Thanks 2
رابط هذا التعليق
شارك

السلام عليكم

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

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

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

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

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

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

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

اخير.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("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

  • Like 4
  • Thanks 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information