ترحيل البيانات من ورقه 1 الى ورقة 2 بشروط

[haiderkh]

لدينا عشرون اسم (العدد غير ثابت) اريد توزيعها في ورقة رقم 2 على ضوء المخطط في اعلاه (جدول عدد اعمدته بعدد الرقم في خليه F6 وعدد صفوفه بعدد الرقم في خليه

F7 وفي المثال المرفق توضيح اكثر . وعذرا للاطالة وكثرة الأسئله في اليومين الماضيين . لكنكم اهل لفعل الخير وهو ما شجعني لطرح اسئلتي هنا

بارك الله بكم

المصنف1.xlsx

[haiderkh]

شكرا جزيلا استاذ في بي ايه اكسيل لسرعة ردك

ساوضح المتوقع من نتائج في ورقه 2

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

جرب هذا الملف

هناك خياران الصفحة Targ والصفحة second_sh

لا ادري ايهما تريد

 

 

Copy_Many_times.xlsm

[عبدالفتاح في بي اكسيل]

عندي  ملاحظة  لا ادري  هذا  القائم على هذا  الموقع  يقوم بحدف  بعض  التعليقات  يبدو انه  لايميز  متى ما اراد  يقوم بحدف  التعليقات  رغم اني  تعليقاتي  لايوجد بها  تجاوزات  ويا ريت يشرحلنا ليش  عم بيحدف  تعليقاتي  وليست  المرة الاولى 

[haiderkh]

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

دمت موفقا

[عبد القادر محمد مهدى]

استاذ سليم

ممكن أبدأ من الخلية (B3) بدلا من (A3)

شكرا لحضرتك

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

ممكن ذلك بهذا التعديل على الماكرو

Option Explicit
Sub Copy_As_you_Like1()
Dim S As Worksheet, sec As Worksheet
Dim i%
Dim Last%, m%, k%, Howmay_row
Set S = Sheets("Source"): Set sec = Sheets("second_sh")
sec.Range("A3").CurrentRegion.Clear
m = S.Range("F6"): Howmay_row = S.Range("F7")
Last = S.Cells(Rows.Count, 2).End(3).Row
m = 3: k = 2
 For i = 3 To Last
  sec.Cells(m, k) = S.Cells(i, 3)
  sec.Cells(m, k + 1) = S.Cells(i, 2)
    m = m + 1
   
  If m Mod (Howmay_row + 3) = 0 Then
   m = 3: k = k + 2
   End If
 Next
 With sec.Range("B3").CurrentRegion
  .Interior.ColorIndex = 6
  .Borders.LineStyle = 1
  .InsertIndent 1
 End With
End Sub

 

[عبد القادر محمد مهدى]

شكراً لك استاذ سليم

نفع الله بعلمك وزادك علما الى علمك

[عبد القادر محمد مهدى]

استاذ سليم بعد تشغيل الكود الجديد عكس عمود (name - id) كما قى الصورة  

 

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

قم باستبدال  2 و 3 في هذين السطرين من الكود (اكتب 2 ماكن الــ  3    و 3 مكان الــ  2)

   sec.Cells(m, k) = S.Cells(i, 3)
   sec.Cells(m, k + 1) = S.Cells(i, 2)

 

[عبد القادر محمد مهدى]

تسلم استاذ سليم 

موفق دائما

[haiderkh]

في 22‏/2‏/2020 at 15:18, سليم حاصبيا said:

ممكن ذلك بهذا التعديل على الماكرو

Option Explicit
Sub Copy_As_you_Like1()
Dim S As Worksheet, sec As Worksheet
Dim i%
Dim Last%, m%, k%, Howmay_row
Set S = Sheets("Source"): Set sec = Sheets("second_sh")
sec.Range("A3").CurrentRegion.Clear
m = S.Range("F6"): Howmay_row = S.Range("F7")
Last = S.Cells(Rows.Count, 2).End(3).Row
m = 3: k = 2
 For i = 3 To Last
  sec.Cells(m, k) = S.Cells(i, 3)
  sec.Cells(m, k + 1) = S.Cells(i, 2)
    m = m + 1
   
  If m Mod (Howmay_row + 3) = 0 Then
   m = 3: k = k + 2
   End If
 Next
 With sec.Range("B3").CurrentRegion
  .Interior.ColorIndex = 6
  .Borders.LineStyle = 1
  .InsertIndent 1
 End With
End Sub

 

السلام عليكم استاذ سليم حاصبيا

بارك الله بك لمساهماتك القيمة واجاباتك الشافيه الوافيه

الكود الذي تفضلت بذكره في أعلاه ممتاز ويعمل جيدا 

ولكن كيف يمكن ان نغير فيه ليتعامل مع أربعة أعمدة بدل من عمودين  كما هو الان

اي ان يقوم بتوزيع أربعة أعمدة 

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

ارفع مثالاَ عما تريده

[haiderkh]

الأستاذ سليم حاصبيا السلام عليكم

هذا هو المثال ارجو الاطلاع عليه جزاك الله خيرا وان كان لديك الوقت ارجو تقييم اخطاءة واسف جدا لاني اثقل عليك

TEST2.rar

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

لقد وضعت ملفاً بهذا الموضوع قبل ان ترفع مثالك

ارجو ان يكون المطلوب

الكود

Option Explicit
Sub Copy_By_Choise()
Rem   Created By Salim Hasbays On 1/3/2020
Application.ScreenUpdating = False
On Error GoTo End_Me
Dim S As Worksheet, T As Worksheet
Dim i%, col%, X%, Last%, m%, k%, Howmay_row%
Dim Title_arr
Set S = Sheets("Source"): Set T = Sheets("Target")
col = T.Cells(2, Columns.Count).End(1).Column
If col = 1 Then col = 500
Howmay_row = S.Range("G2")
Title_arr = Application.Transpose(S.Range("a1:d1"))
Title_arr = Application.Transpose(Title_arr)
Last = S.Cells(Rows.Count, 2).End(3).Row
T.Range("A2").Resize(Last, col).Clear
m = 3: k = 1
 For i = 2 To Last
   For X = 0 To 3
      T.Cells(m, k).Offset(, X) = _
      S.Cells(i, 1).Offset(, X)
   Next X
   m = m + 1

   If m Mod (Howmay_row + 3) = 0 Then m = 3: k = k + 5
Next i
col = T.Cells(3, Columns.Count).End(1).Column
 For k = 1 To col Step 5
  Cells(2, k).Resize(, 4) = Title_arr
 With T.Range("B2").Offset(, k - 1).CurrentRegion
  .Interior.ColorIndex = 6
  .Borders.LineStyle = 1
  .InsertIndent 1
 End With
 Next
 Erase Title_arr: Set S = Nothing: Set T = Nothing
End_Me:
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

 

Split_table.xlsm

[haiderkh]

الاستاذ سليم حاصبيا

حبذا لو تم التعديل على المثال المرفق لان الكود لم يعمل لدي مع العلم تم تغيير بعض الامور فيه ليتلائم مع ما موجود لدي

 

[haiderkh]

الاستاذ سليم حاصبيا

شكرا جزيلا لك لا اعرف كيف اشكرك

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

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

وحاولت كثيرا كي اعرف السبب ولم اقدر