كود لنقل بيانات من شيت لشيت اخر بشروط

[emanfci]

 

اخواني الافاضل

احتاج لمعادلة أو كود استخدمه لنقل بيانات من شيت لشيت اخر و لكن مع مراعاة:

هناك 1200 اسم تقريبا في الشيت الأول

 عند النقل يأخذ كل 10 أسماء و يضعهم فى المكان المقابل لهم في الشيت الاخر مع مراعاة وجود عدد 6 صفوف للدباجه بين كل مجموعه و الاخري

 

طلب اخر بعد اذنكم

لدي 1200 اسم تحت كل اسم صف فارغ اريد كود أو معادلة لدمج كل صف مع الذي يليه

وجزاكم الله خيرا 

تم حذف المشاركة الأخرى لأنها مكررة مع هذه المشاركة ..من فضلك لا تكرر نفس المشاركات

 

 

 

 

يناير2017.rar

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

جرب هذا الماكرو (كان من الافضل عدم وجود خلايا مدمجة)

تم تبديل اسم الصفحة الثانية الى اسم بالاجنبية MY_DATA

Sub Copy_With_Merged_Cells()

Const My_step = 26
Dim M As Worksheet, S As Worksheet
Dim I%, Ls%, x%, t%
Dim MX%, R%

Set M = Sheets("MY_DATA")
Set S = Sheets("Sheet1")
  
  MX = Application.Max(M.Range("A:A"))
  Ls = S.Cells(Rows.Count, 1).End(3).Row: Ls = Ls + 1
  R = M.Range("A:A").Find(MX, LookAt:=1).Row
  
 For I = 12 To R Step My_step
  M.Range("B" & I).Resize(19) = ""
 Next
 
 For I = 1 To Ls Step 20
  t = My_step * x + 12
   S.Range("A" & I).Resize(20).Copy M.Range("B" & t)
   x = x + 1
 Next
 M.Columns(2).AutoFit
End Sub

الملف مرفق

Copy_For_Me.xlsm

[emanfci]

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

و لكن هل هناك حل لمشكلة الدمج

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

انشأ صفحة جديدة باسم   Sans_Merge (حيث ستجد الاسماء دون دمج)

و نفذ هذا الماكرو (لا يجوز ان تلغي الدمج في الصفحة الاولى حتى لا يتعطل الماكرو الاول)

Sub Remove_merg()
Dim Ls%

 Ls = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row: Ls = Ls + 1
 Sheets("Sheet1").Range("A1:A" & Ls).Copy Sheets("Sans_Merge").Range("a1")
 Sheets("Sans_Merge").Range("A1:A" & Ls).UnMerge
 Sheets("Sans_Merge").Range("A1:A" & Ls).SpecialCells(4).EntireRow.Delete

End Sub

الملف مرفق من جديد (النتيجة في الصفحة Sans_Merge)

 

Copy_For_Me_new.xlsm

[emanfci]

جزاك الله خيرا أخ سليم  انا لم أقصد إلغاء الدمج بل أريد تنفيذ الدمج علي كل الأسماء لأنها سترحل في شيت الكنترول في خلايا مدمجه

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

قم بإنشاء ملف بسيط (نموذج) من 5 لى 10 صفوف تذكر فية المعطيات والتنيجة (يدوياً)

و ذلك لاني لم افهم ماذا تريد بالضبط     ولا مجال للتخمين واضاعة الوقت

 

[emanfci]

يا فندم هو نفس الملف المسمي sheet1 المدرج به جميع الاسماء لقد قمت بعمل صف زائد تحت كل اسم ثم قمت بدمج كل اسم بالصف الفارغ الذي يليه يدويا

كل اسم علي حده عن طريق الامر merge هذا بالنسبة لل 20 اسم الاولي تقريبا, ولكن اريد ان انفذ هذا علي باقي الاسماء عن طريق كود يفعل ذلك مرة واحدة

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

الكود اللازم

Sub add_names()
Dim Ls%

 Ls = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row: Ls = Ls + 1
 Sheets("Sans_Merge").Range("K:K").Clear
 Sheets("Sheet1").Range("A1:A" & Ls).Copy Sheets("Sans_Merge").Range("K1")
  With Sheets("Sans_Merge").Range("K1:K" & Ls)
    .UnMerge
    .SpecialCells(4).Formula = "=k1"
  End With
End Sub

الملف من جديد 

Rxtra_Copy_For_Me.xlsm

[emanfci]

تسلم أخي علي مجهودك و سعة صدرك ولكن المطلوب ليس تكرار الاسماء في الصف الفارغ ولكن دمج خلية الاسم مع الخلية التي تليها

لتصبح خلية واحدة بها اسم واحد كما هو موضح بالشيت المرفق

Book1.xlsx

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

كنت قد قلت لك سابقاً ارفع تموذج عما تريد ( 10 - 20 سطراً لا أكثر من 2000 صف) ولا تهدر الوقت بامور لا تجدي نفعاً

و الان قد اتضحت الصورة اليك الماكرو المناسب (النتيجة في شيت Salim لانه ربما اردت التعديل بعض الشيء على الماكرو)

الماكرو يعمل على كل البيانات مهما زاد عدد الصفوف في العامود الاول

Option Explicit

Sub Merge_cells()
Dim Sh As Worksheet, Sa As Worksheet
Dim lr_ShA%, i%
Dim my_rg As Range
Set Sh = Sheets("sheet1"): Set Sa = Sheets("Salim")
 Sa.Range("A:A").Clear
 lr_ShA = Sh.Cells(Rows.Count, 1).End(3).Row
 Sh.Cells(1, 1).Resize(lr_ShA + 1).Copy
 Sa.Cells(1, 1).PasteSpecial
 Application.CutCopyMode = False
 Sa.Cells(1, 3).Select
  
  For i = 1 To lr_ShA Step 2
    Sa.Cells(i, 1).Resize(2).Merge
  Next
  
  With Sa.Cells(1, 1).Resize(lr_ShA)
    .VerticalAlignment = 2
    .InsertIndent 1
  End With
End Sub

المثال مرفق

 

tajriba.xlsm

[emanfci]

أثقلت عليك سيدي هذ هو المطلوب بالفعل ولكن عند Run  يطبق علي ال 20 اسم الاولي و يخفي باقي الاسماء

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

لو لاحظت الصفحة الاولى لرأيت انها تحتوي على 20 اسم فقط (قمت بحذف كمية كبيرة من الاسماء لمتابعة عمل الكود والتحقق انه يقوم بالمطلوب )

و لكن اذا نسخت الكود الى ملفك فسوف يعمل على كل الاسماء 

[emanfci]

جزاك الله كل الخير و متعك بالصحة و العافية أستاذي الفاضل 

تم تشغيل كل الأكواد بنجاح 

[emanfci]

سيدي الفاضل أعرف أنني أثقلت عليك 

أريد أن انسخ محتويات هذا الشيت 120 مرة في نفس الشيت مع مراعاه نسخ المعادلات و التنسيقات 

مع تثبيت جزء الدباجه العلوية و أسماء المواد كما هو بالملف المرفق

يناير2017.xls