دمج شيتلا في شيت واحد عبر ترحيل البيانات

[khaldounabouisrae]

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

المرجو مساعدتي و جازاكم الله خيرا

ListEleve_20240320.xlsx

[meeedo63]

السلام عليكم 

ممكن تشوف الملف كدة يمكن يساعدك

ListEleve_20240320.rar

[khaldounabouisrae]

تحية طيبة اخي 

لكني لم اجد كود الترحيل

[محمد هشام.]

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

Sub transfert()
Dim desWS As Worksheet: Set desWS = Sheets("تجميع")
Dim i As Byte, F As Variant

Application.ScreenUpdating = False

desWS.Range("a2:j" & Rows.Count).ClearContents
For i = 1 To Worksheets.Count
    If UCase(Sheets(i).Name) <> desWS.Name Then
    
With Sheets(i)
  
F = .Range("A10:G10", .Range("a" & Rows.Count).End(xlUp))
desWS.[A65000].End(xlUp).Offset(2).Resize(UBound(F), 7) = F
   
        End With
    End If
Next
Application.ScreenUpdating = True
End Sub

  في حالة الرغبة بتنسيق الجداول يمكنك اظافة الاسطر التالية اسفل الكود 

'تنسيق الجداول

                                  '''*****تسطير*****
With desWS
lastrow = .Range("A:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 Set rngCell = .Range("A2 :G" & lastrow)
 For Each c In rngCell.Rows
   If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
Next

                                     '''****تمييز رؤوس الاعمدة***
  Set j = .Range("a2:a" & lastrow)
  For Each r In j
    If r.Value = "ر.ت" Then _
      If rng Is Nothing Then Set rng = r.Resize(1, 7) Else Set rng = Union(rng, r.Resize(1, 7))
     Next
  If Not rng Is Nothing Then rng.Interior.Color = RGB(204, 204, 255): rng.Font.Bold = True
End With

 

ListEleve_20240320 V2.xlsm

تم تعديل مارس 20 بواسطه محمد هشام.

[khaldounabouisrae]

اقتباس

 

شكرا اخي محمد هشام جازاك الله الف الف خير