على حسن قام بنشر يناير 16, 2017 مشاركة قام بنشر يناير 16, 2017 لدى مجموعه من الشيتات وبكل شيت مجموعة بيانات واريد نسخ جميع الشيتات فى شيت واحد وجزاكم الله خيرا نسخ الشيتات.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يناير 16, 2017 مشاركة قام بنشر يناير 16, 2017 جرب هذا الماكرو Sub copy_All() Application.ScreenUpdating = False Dim My_sh As Worksheet Dim My_range As Range Dim k, m, lr, i As Integer k = Sheets.Count m = 3 Set My_sh = Sheets(k) My_sh.Range("a3:m1000").ClearContents For i = 2 To k - 1 With Sheets(i) lr = .Cells(Rows.Count, 1).End(3).Row Set My_range = .Range("a6:k" & lr) End With With My_sh .Cells(m, 1) = Sheets(i).Cells(1, 2) .Cells(m, 2) = Sheets(i).Cells(2, 2) My_range.Copy .Range("c" & m).PasteSpecial xlPasteValues m = m + lr - 4 End With Next My_sh.Activate Range("a3").Select Application.ScreenUpdating = True End Sub 4 رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر يناير 18, 2017 الكاتب مشاركة قام بنشر يناير 18, 2017 استاذ / سليم حاصبيا الكود اكثر من رائع وهو المطلوب بالضبط لكن اذا سمحت لى تعديل بسيط وهو استثناء الشيتات المخفيه من النسخ وجزاك الله خيرا رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يناير 18, 2017 مشاركة قام بنشر يناير 18, 2017 1 ساعه مضت, على حسن said: استاذ / سليم حاصبيا الكود اكثر من رائع وهو المطلوب بالضبط لكن اذا سمحت لى تعديل بسيط وهو استثناء الشيتات المخفيه من النسخ وجزاك الله خيرا استيدل الكود بهذا Sub copy_All_visible() Application.ScreenUpdating = False Dim My_sh As Worksheet Dim My_range As Range Dim k, m, lr, i, x As Integer Dim arrsh() As Integer k = Sheets.Count: m = 3: Set My_sh = Sheets(k): My_sh.Range("a3:m1000").ClearContents For i = 1 To k - 1 If Sheets(i).Visible = True Then t = t + 1: x = Sheets(i).Index ReDim Preserve arrsh(1 To t) arrsh(t) = Sheets(i).Index End If Next For y = 1 To UBound(arrsh) With Sheets(arrsh(y)) lr = .Cells(Rows.Count, 1).End(3).Row Set My_range = .Range("a6:k" & lr) End With With My_sh .Cells(m, 1) = Sheets(arrsh(y)).Cells(1, 2) .Cells(m, 2) = Sheets(arrsh(y)).Cells(2, 2) My_range.Copy .Range("c" & m).PasteSpecial xlPasteValues m = m + lr - 4 End With Next My_sh.Activate Range("a3").Select Erase arrsh Application.ScreenUpdating = True End Sub 4 1 رابط هذا التعليق شارك More sharing options...
جلال الجمال_ابو أدهم قام بنشر يناير 18, 2017 مشاركة قام بنشر يناير 18, 2017 سليم حاصبيا اخى الفاضل ما شاء الله عليك 1 رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر يناير 18, 2017 الكاتب مشاركة قام بنشر يناير 18, 2017 استاذ / سليم حاصبيا جزاك الله خيراً وجعله الله فى ميزان حسناتك 1 رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر فبراير 12, 2017 الكاتب مشاركة قام بنشر فبراير 12, 2017 استاذ / سليم حاصبيا بعد اذن حضرتك لى طلب اخر على شيت مختلف واتمنى الا اكون اكثرت الطلبات المطلوب نسخ الشيتات بشرط رقم المسلسل نسخ الشيتات بشرط رقم المسلس.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 13, 2017 مشاركة قام بنشر فبراير 13, 2017 جرب هذا الماكرو (تستبدل اسم اخر شيت الى Repport لحسن التعامل مع اللغة الاجنبية) مرفق الملف Sub copy_spcial_cells() Dim Ws_Source As Worksheet Dim My_Sheet As Worksheet Dim My_NUm, x, s, lr, k, i As Integer Dim My_Rg As Range Set Ws_Source = Sheets("Repport") With Ws_Source .Select .Range("a4:d1000").ClearContents My_NUm = .Range("b1") End With x = 4 k = Sheets.Count For i = 1 To k - 1 Set My_Sheet = Sheets(i) lr = My_Sheet.Cells(Rows.Count, "e").End(3).Row If lr < 5 Then lr = 5 For s = 5 To lr If Sheets(i).Range("E" & s) = My_NUm Then With Ws_Source .Range("a" & x) = My_Sheet.Range("b1") .Range("b" & x) = My_Sheet.Range("b2") .Range("c" & x) = My_Sheet.Range("b" & s) .Range("d" & x) = My_Sheet.Range("a" & s) End With x = x + 1 End If Next Next End Sub Report salim.rar 3 رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر فبراير 13, 2017 الكاتب مشاركة قام بنشر فبراير 13, 2017 (معدل) استاذ / سليم حاصبيا جزاك الله خيرا وزاداك الله من علمه تم تعديل فبراير 13, 2017 بواسطه على حسن رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر فبراير 18, 2017 الكاتب مشاركة قام بنشر فبراير 18, 2017 استاذ / سليم حاصبيا بعد التحيه اولاً اشكرك جزيل الشكر على العلم والمجهود الرائع الدى تقدمه لى وللاعضاء فى اوفيسنا ثانيا اتمنى الااكون ثقيلا فى طلباتى ولك منى كل احترام وتقدير فى ما تقدمه لى وللاعضاء لى تعديل اخر بعد اذن حضرتك وهوا ادراج كل مسلسل والاجمالى Report salim.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 18, 2017 مشاركة قام بنشر فبراير 18, 2017 جرب هذا الماكرو (تستبدل اسم اخر شيت الى Repport لحسن التعامل مع اللغة الاجنبية) 2 ساعات مضت, على حسن said: استاذ / سليم حاصبيا بعد التحيه اولاً اشكرك جزيل الشكر على العلم والمجهود الرائع الدى تقدمه لى وللاعضاء فى اوفيسنا ثانيا اتمنى الااكون ثقيلا فى طلباتى ولك منى كل احترام وتقدير فى ما تقدمه لى وللاعضاء لى تعديل اخر بعد اذن حضرتك وهوا ادراج كل مسلسل والاجمالى Report salim.rar جرب هذا الماكرو Sub Give_Me_Sum() 'Author Salim 18/02/2017 Officena Dim my_rg As Range Dim lr, lrF, lrK, k, i As Integer, s, My_NUm, Oldval As Long With Sheets("Repport") lrF = .Cells(Rows.Count, "f").End(3).Row Set my_rg = .Range("f2:f" & lrF) .Range("G2:I" & lrF + 1).ClearContents .Cells(lrF + 1, "h") = "المجموع" .Cells(lrF + 1, "i") = 0 End With For i = 2 To lrF My_NUm = my_rg.Cells(i - 1) For k = 1 To Sheets.Count - 1 With Sheets(k) lrK = .Cells(Rows.Count, "e").End(3).Row For y = 5 To lrK If .Range("e" & y) = My_NUm Then _ s = s + .Range("e" & y).Offset(0, 1) Next End With Next my_rg.Cells(i - 1).Offset(0, 1) = s Oldval = Sheets("Repport").Cells(lrF + 1, "i") Sheets("Repport").Cells(lrF + 1, "i") = Oldval + s s = 0 Next End Sub 1 رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر فبراير 18, 2017 الكاتب مشاركة قام بنشر فبراير 18, 2017 استاذ / سليم حاصبيا والله انتا باشا 1 رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر فبراير 20, 2017 الكاتب مشاركة قام بنشر فبراير 20, 2017 استاذى العزيز سليم حاصبيا الكود اكثر من رائع لكنه لا ينسخ الشيت الاخير الاجمالى.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 20, 2017 مشاركة قام بنشر فبراير 20, 2017 1 ساعه مضت, على حسن said: استاذى العزيز سليم حاصبيا الكود اكثر من رائع لكنه لا ينسخ الشيت الاخير الاجمالى.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 20, 2017 مشاركة قام بنشر فبراير 20, 2017 منذ ساعه, سليم حاصبيا said: يجب ان تكون الورقة Repport اخر ورقة في المصنف و ليس الاولى و لا لزوم للورقة Sheet1 الفارغة اذا اردت زيادة ورقة يحب ان تكون البيانات فيها تماماً مثل بقية الاوراق (المعومات تبدأ في نفس الصف والاعمدة نفسها) 1 رابط هذا التعليق شارك More sharing options...
على حسن قام بنشر فبراير 21, 2017 الكاتب مشاركة قام بنشر فبراير 21, 2017 استاذى العزيز سليم حاصبيا اذا كان عدد الشيتات اكثر من 1200 شيت فهل هناك طريقه لجعله اخر الشيتات رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 21, 2017 مشاركة قام بنشر فبراير 21, 2017 3 ساعات مضت, على حسن said: استاذى العزيز سليم حاصبيا اذا كان عدد الشيتات اكثر من 1200 شيت فهل هناك طريقه لجعله اخر الشيتات استعمل هذا الماكرو الصغير Sub Move_sheet() Sheets("Repport").Move After:=Sheets(Sheets.Count) End Sub 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان