haiderkh قام بنشر فبراير 21, 2020 مشاركة قام بنشر فبراير 21, 2020 لدينا عشرون اسم (العدد غير ثابت) اريد توزيعها في ورقة رقم 2 على ضوء المخطط في اعلاه (جدول عدد اعمدته بعدد الرقم في خليه F6 وعدد صفوفه بعدد الرقم في خليه F7 وفي المثال المرفق توضيح اكثر . وعذرا للاطالة وكثرة الأسئله في اليومين الماضيين . لكنكم اهل لفعل الخير وهو ما شجعني لطرح اسئلتي هنا بارك الله بكم المصنف1.xlsx رابط هذا التعليق شارك More sharing options...
haiderkh قام بنشر فبراير 21, 2020 الكاتب مشاركة قام بنشر فبراير 21, 2020 شكرا جزيلا استاذ في بي ايه اكسيل لسرعة ردك ساوضح المتوقع من نتائج في ورقه 2 رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر فبراير 21, 2020 أفضل إجابة مشاركة قام بنشر فبراير 21, 2020 جرب هذا الملف هناك خياران الصفحة Targ والصفحة second_sh لا ادري ايهما تريد Copy_Many_times.xlsm 4 1 رابط هذا التعليق شارك More sharing options...
عبدالفتاح في بي اكسيل قام بنشر فبراير 21, 2020 مشاركة قام بنشر فبراير 21, 2020 عندي ملاحظة لا ادري هذا القائم على هذا الموقع يقوم بحدف بعض التعليقات يبدو انه لايميز متى ما اراد يقوم بحدف التعليقات رغم اني تعليقاتي لايوجد بها تجاوزات ويا ريت يشرحلنا ليش عم بيحدف تعليقاتي وليست المرة الاولى 2 1 رابط هذا التعليق شارك More sharing options...
haiderkh قام بنشر فبراير 22, 2020 الكاتب مشاركة قام بنشر فبراير 22, 2020 الأستاذ سليم حاصبيا شكرا جزيلا لك زادك الله من علمه وجعل ذلك في ميزان حسناتك دمت موفقا رابط هذا التعليق شارك More sharing options...
عبد القادر محمد مهدى قام بنشر فبراير 22, 2020 مشاركة قام بنشر فبراير 22, 2020 استاذ سليم ممكن أبدأ من الخلية (B3) بدلا من (A3) شكرا لحضرتك 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 22, 2020 مشاركة قام بنشر فبراير 22, 2020 ممكن ذلك بهذا التعديل على الماكرو 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 2 1 رابط هذا التعليق شارك More sharing options...
عبد القادر محمد مهدى قام بنشر فبراير 22, 2020 مشاركة قام بنشر فبراير 22, 2020 شكراً لك استاذ سليم نفع الله بعلمك وزادك علما الى علمك 1 رابط هذا التعليق شارك More sharing options...
عبد القادر محمد مهدى قام بنشر فبراير 23, 2020 مشاركة قام بنشر فبراير 23, 2020 استاذ سليم بعد تشغيل الكود الجديد عكس عمود (name - id) كما قى الصورة 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 23, 2020 مشاركة قام بنشر فبراير 23, 2020 قم باستبدال 2 و 3 في هذين السطرين من الكود (اكتب 2 ماكن الــ 3 و 3 مكان الــ 2) sec.Cells(m, k) = S.Cells(i, 3) sec.Cells(m, k + 1) = S.Cells(i, 2) 1 1 رابط هذا التعليق شارك More sharing options...
عبد القادر محمد مهدى قام بنشر فبراير 23, 2020 مشاركة قام بنشر فبراير 23, 2020 تسلم استاذ سليم موفق دائما 1 رابط هذا التعليق شارك More sharing options...
haiderkh قام بنشر مارس 1, 2020 الكاتب مشاركة قام بنشر مارس 1, 2020 في 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 السلام عليكم استاذ سليم حاصبيا بارك الله بك لمساهماتك القيمة واجاباتك الشافيه الوافيه الكود الذي تفضلت بذكره في أعلاه ممتاز ويعمل جيدا ولكن كيف يمكن ان نغير فيه ليتعامل مع أربعة أعمدة بدل من عمودين كما هو الان اي ان يقوم بتوزيع أربعة أعمدة رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مارس 1, 2020 مشاركة قام بنشر مارس 1, 2020 ارفع مثالاَ عما تريده 1 رابط هذا التعليق شارك More sharing options...
haiderkh قام بنشر مارس 1, 2020 الكاتب مشاركة قام بنشر مارس 1, 2020 الأستاذ سليم حاصبيا السلام عليكم هذا هو المثال ارجو الاطلاع عليه جزاك الله خيرا وان كان لديك الوقت ارجو تقييم اخطاءة واسف جدا لاني اثقل عليك TEST2.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مارس 1, 2020 مشاركة قام بنشر مارس 1, 2020 لقد وضعت ملفاً بهذا الموضوع قبل ان ترفع مثالك ارجو ان يكون المطلوب الكود 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 2 1 رابط هذا التعليق شارك More sharing options...
haiderkh قام بنشر مارس 1, 2020 الكاتب مشاركة قام بنشر مارس 1, 2020 الاستاذ سليم حاصبيا حبذا لو تم التعديل على المثال المرفق لان الكود لم يعمل لدي مع العلم تم تغيير بعض الامور فيه ليتلائم مع ما موجود لدي رابط هذا التعليق شارك More sharing options...
haiderkh قام بنشر مارس 3, 2020 الكاتب مشاركة قام بنشر مارس 3, 2020 الاستاذ سليم حاصبيا شكرا جزيلا لك لا اعرف كيف اشكرك ولكن اسال الله ان يجزيك خيرا على كل ما قدمت الكود بعد التغيير يعمل بشكل صحيح عدا البيانات في السطر الاول من المجموعة الاولى تكون فارغة وبياناتها تظهر في ورقة اخرى وحاولت كثيرا كي اعرف السبب ولم اقدر رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.