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

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

قام بنشر

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

اخواني الكرام

عندي ملف اكسل يتوفر على 20 شيت (ورقة عمل )  تضم جداول  بها نفس الاعمدة و اسطر متفاوتة 

و اريد نقلها الى شيت واحد  يعني 

الجدول الموجود بالشيت الاول 

واسفله الجدول الموجود بالشيت الثاني 

وهكذا الى الوصول الى الشيت رقم 20   .... عنوان مخالف ... تـــم تعديل وتغيير عنوان المشاركة ليعبر عن طلبك

ملف.xlsx

  • أفضل إجابة
قام بنشر

جرب هذا الكود

تم تغيير اسم الصفحة الرئيسية الى اللغة الأجنبية (Central) لسهولة نسخ الكود ولصقة (دون ظهور احرف غريبة فيه)

Option Explicit
Sub One_For_all()
    Dim Ar_sheet()
    Dim m%, x%, Ro%, Itm, ct_ro%
    Dim Rg As Range, CT As Worksheet
    Dim ct_rg As Range
    Dim Var_rg As Range, var_ro%, var_col%
Application.ScreenUpdating = False
  
  Set CT = Sheets("Central")
  Set ct_rg = CT.Range("A1").CurrentRegion
 ct_ro = ct_rg.Rows.Count
    If ct_ro > 1 Then
      ct_rg.Offset(1).Resize(ct_ro - 1).Clear
    End If

For m = 0 To Sheets.Count - 1
    If Sheets(m + 1).Name <> CT.Name Then
      ReDim Preserve Ar_sheet(m)
      Ar_sheet(m) = Sheets(m + 1).Name
    End If
 Next
 m = 2
 
 For Each Itm In Ar_sheet
 Set Var_rg = Sheets(Itm).Range("A1").CurrentRegion
  var_ro = Var_rg.Rows.Count
  var_col = Var_rg.Columns.Count
   If var_ro > 1 Then
      CT.Cells(m, 2).Resize(var_ro - 1, var_col - 1).Value = _
      Sheets(Itm).Range("B2") _
      .Resize(var_ro - 1, var_col - 1).Value
   m = m + var_ro - 1
  
  End If
 
 Next Itm
  If m > 2 Then
       With CT.Range("A2").Resize(m - 2, var_col)
         .Columns(1) = Evaluate("Row(1:" & m - 2 & ")")
         .Borders.LineStyle = 1
         .InsertIndent 1
         .Font.Bold = True
         .Font.Size = 14
         .Interior.ColorIndex = 35
       End With
  End If
  Application.ScreenUpdating = True
End Sub

الملف مرفق

Moustafa7.xlsm

  • Like 3
قام بنشر

شكرا جزيلا اخي الكريم 

لكن هناك بعض الاعمدة 

K L M N O P Q R S

 لم تنقل 

جزاك الله خيرا  ، فعلا هذا هو الكود الذي كنت ابحث عنه 

وهل هناك طريقة للحفاظ على التنسيقات نوع الخط و اللون

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

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

Important Information