مصطفى7 قام بنشر يناير 26, 2021 قام بنشر يناير 26, 2021 السلام عليكم و رحمة الله وبركاته اخواني الكرام عندي ملف اكسل يتوفر على 20 شيت (ورقة عمل ) تضم جداول بها نفس الاعمدة و اسطر متفاوتة و اريد نقلها الى شيت واحد يعني الجدول الموجود بالشيت الاول واسفله الجدول الموجود بالشيت الثاني وهكذا الى الوصول الى الشيت رقم 20 .... عنوان مخالف ... تـــم تعديل وتغيير عنوان المشاركة ليعبر عن طلبك ملف.xlsx
أفضل إجابة سليم حاصبيا قام بنشر يناير 27, 2021 أفضل إجابة قام بنشر يناير 27, 2021 جرب هذا الكود تم تغيير اسم الصفحة الرئيسية الى اللغة الأجنبية (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 3
مصطفى7 قام بنشر يناير 27, 2021 الكاتب قام بنشر يناير 27, 2021 شكرا جزيلا اخي الكريم لكن هناك بعض الاعمدة K L M N O P Q R S لم تنقل جزاك الله خيرا ، فعلا هذا هو الكود الذي كنت ابحث عنه وهل هناك طريقة للحفاظ على التنسيقات نوع الخط و اللون
الردود الموصى بها