saif_5 قام بنشر يوليو 19, 2017 مشاركة قام بنشر يوليو 19, 2017 السلام عليكم عندي هذا الملف فيه خطأ بالكود اذا ممكن احد يتكرم ويشوفه لي شكرا لكم :) الترحيل.zip رابط هذا التعليق شارك More sharing options...
ابراهيم الحداد قام بنشر يوليو 19, 2017 مشاركة قام بنشر يوليو 19, 2017 السلام عليكم ورحمة الله الكود بعد التعديل Sub saif() Dim sh As Worksheet LR = Cells(Rows.Count, 1).End(xlUp).Row For Each sh In ThisWorkbook.Worksheets For r = 2 To LR If sh.Name = "البرنامج" Then GoTo 2 If Sheets("البرنامج").Cells(r, 1).Value <> Empty Then If Sheets("البرنامج").Cells(r, 1).Value = sh.Name Then Sheets("البرنامج").Range("D" & r & ":M" & r).Copy qq = sh.Cells(100000, 1).End(xlUp).Row + 1 sh.Range("a" & qq).PasteSpecial xlPasteValues End If End If Next 2 Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub 1 رابط هذا التعليق شارك More sharing options...
saif_5 قام بنشر يوليو 20, 2017 الكاتب مشاركة قام بنشر يوليو 20, 2017 شكرا لك يا استاذ زيزو .. الله يجزاك الجنة طيب اذا الشيتات اللي عايز ارحل لهااكثر من 2 هل اغير شي على الكود ؟ رابط هذا التعليق شارك More sharing options...
ابراهيم الحداد قام بنشر يوليو 20, 2017 مشاركة قام بنشر يوليو 20, 2017 (معدل) السلام عليكم ورحمة الله الكود يصلح للعديد من الشيتات المهم ان تكون اسماؤها متطابقة تم تعديل يوليو 20, 2017 بواسطه زيزو العجوز 1 رابط هذا التعليق شارك More sharing options...
عبدللرحيم قام بنشر يوليو 21, 2017 مشاركة قام بنشر يوليو 21, 2017 جزيل الشكر للخبير زيزو العجوز برجاء تعديل الكود لفحص عدم تكرار الترحيل رابط هذا التعليق شارك More sharing options...
saif_5 قام بنشر يوليو 22, 2017 الكاتب مشاركة قام بنشر يوليو 22, 2017 في ٢٠/٧/٢٠١٧ at 23:09, زيزو العجوز said: السلام عليكم ورحمة الله الكود يصلح للعديد من الشيتات المهم ان تكون اسماؤها متطابقة شكرا لك يا استاذ زيزو وهل فيه امكانية عدم تكرار الترحيل مثل ما قال الاخ عبدالرحيم ؟ رابط هذا التعليق شارك More sharing options...
ابراهيم الحداد قام بنشر يوليو 22, 2017 مشاركة قام بنشر يوليو 22, 2017 السلام عليكم ورحمة الله الطريقة الوحيدة على حد علمى لعدم تكرار الترحيل هو مسح البيانات القديمة من الورقة الاساسية رابط هذا التعليق شارك More sharing options...
saif_5 قام بنشر يوليو 31, 2017 الكاتب مشاركة قام بنشر يوليو 31, 2017 السلام عليكم يا استاذ زيزو اذا تتكرم بعمل كود يرحل المطلوب بالملف .. هو نفس الملف اللي بأول الموضوع بس هالمره العكس بيانات من عدة صفحات تترحل الى صفحة عمل واحدة الترحيل 1.zip رابط هذا التعليق شارك More sharing options...
ابراهيم الحداد قام بنشر أغسطس 2, 2017 مشاركة قام بنشر أغسطس 2, 2017 السلام عليكم ورحمة الله استخدم هذا الكود Sub saif2() Dim LR As Long, LS As Long Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets If sh.Name <> "البرنامج" Then LS = sh.Cells(Rows.Count, 11).End(xlUp).Row sh.Range("K" & LS & ": L" & LS).Copy LR = Sheets("البرنامج").Cells(Rows.Count, 16).End(xlUp).Row + 1 Sheets("البرنامج").Range("P" & LR).PasteSpecial xlPasteValues End If Next sh Application.CutCopyMode = False Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
saif_5 قام بنشر أغسطس 2, 2017 الكاتب مشاركة قام بنشر أغسطس 2, 2017 السلام عليكم يا استاذ زيزو انا جربت الكود بس طلع لي مشكله لما اعمل الترحيل ينسخ لي البيانات حتى لو ما كان الرمز نفس اسم ورقة العمل ، يعني ينسخها في اخر خليه فاضية انا عايزه ينسخها لي امام نفس الرمز واذا لا يوجد شي ينسخه يتركها فاضية وينتقل للرمز الثاني وينسخ البيانات الموجوده في الاسم المطابق امام نفس الاسم فقط جزاك الله خير بغلبك معي :) رابط هذا التعليق شارك More sharing options...
ابراهيم الحداد قام بنشر أغسطس 2, 2017 مشاركة قام بنشر أغسطس 2, 2017 السلام عليكم ورحمة الله اعتقد انك تقصد هذا الكود Sub saif2() Dim LR As Long, LS As Long, R As Long Dim sh As Worksheet LR = Sheets("البرنامج").Cells(Rows.Count, 1).End(xlUp).Row For Each sh In ThisWorkbook.Worksheets LS = sh.Cells(Rows.Count, 11).End(xlUp).Row For R = 2 To LR If sh.Name = Sheets("البرنامج").Range("A" & R) Then Sheets("البرنامج").Range("P" & R) = sh.Range("K" & LS) Sheets("البرنامج").Range("Q" & R) = sh.Range("L" & LS) End If Next Next sh Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
saif_5 قام بنشر أغسطس 3, 2017 الكاتب مشاركة قام بنشر أغسطس 3, 2017 جزاك الله خير يا استاذ زيزو هو هذا المطلوب طيب طلب اخير اذا تكرمت .. كود يحسب لي العمود K و L بنفس الدالة اللي حاسبهم يدوي في الشيتات اللي اسمائهم 1010 و 1020 تلقائي بمجرد ما ارحل البيانات من A الى J رابط هذا التعليق شارك 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.