حسين مامون قام بنشر أغسطس 4, 2016 مشاركة قام بنشر أغسطس 4, 2016 (معدل) السلام عليكم ورحمة الله اخواني اريد ترحيل بيانات من الشيت "الرءيسية " الى الصفحات المرقمة الموضوت شرحته في المرفق جزاكم الله خيرا Copie de الترحيل حسب رقم الشيت.zip تم تعديل أغسطس 4, 2016 بواسطه حسين22 ارفاق النمودج رابط هذا التعليق شارك More sharing options...
أبو حنــــين قام بنشر أغسطس 4, 2016 مشاركة قام بنشر أغسطس 4, 2016 السلام عليكم جرب هذا الكود Sub CopyToSheets() Application.ScreenUpdating = False Dim i As Integer, sh As Worksheet, HS As Worksheet, Lr As Integer, iLr As Integer Set sh = Sheets("ÇáÑÆíÓíÉ") With sh Lr = .Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To Lr 'Sheets.Count For Each HS In Sheets If HS.Name = sh.Cells(i, 1) Then iLr = HS.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & i).Resize(, 7).Copy HS.Range("A" & iLr).PasteSpecial (xlPasteValues) End If Next Next End With Application.ScreenUpdating = True Application.CutCopyMode = False End Sub 2 رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر أغسطس 5, 2016 الكاتب مشاركة قام بنشر أغسطس 5, 2016 شكرا استاد ساجرب انشاء الله رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر أغسطس 5, 2016 الكاتب مشاركة قام بنشر أغسطس 5, 2016 السلام عليكم استاد الكود يعمل انه راءع حفظك الله ورعاك تعديل بسيط في الكود اريد افراغ البيانات من الرءيسية بعد الترحيل رابط هذا التعليق شارك More sharing options...
أبو حنــــين قام بنشر أغسطس 5, 2016 مشاركة قام بنشر أغسطس 5, 2016 لمسح المحتويات Sub CopyToSheets() Application.ScreenUpdating = False Dim i As Integer, sh As Worksheet, HS As Worksheet, Lr As Integer, iLr As Integer Set sh = Sheets("الرئيسية") With sh Lr = .Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To Lr 'Sheets.Count For Each HS In Sheets If HS.Name = sh.Cells(i, 1) Then iLr = HS.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & i).Resize(, 7).Copy HS.Range("A" & iLr).PasteSpecial (xlPasteValues) End If Next Next .Range("A2:G" & Lr).ClearContents End With Application.ScreenUpdating = True Application.CutCopyMode = False End Sub 1 رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر أغسطس 5, 2016 الكاتب مشاركة قام بنشر أغسطس 5, 2016 حفظك الله يا اخي ورعاك ورزقك من الحلال ما تريد هل يمكن اضافة msgboxعند الترحيل الى رقم غير موجد يتوقف الترحيل جزاك الله خيرا رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر أغسطس 5, 2016 مشاركة قام بنشر أغسطس 5, 2016 بعد اذن الاخ ابو حنين هذا الكود ربما يكون اسرع قليلاً Sub transpos_data() Dim Sh_Principal As Worksheet Dim lr As Integer Dim my_row As Integer Set Sh_Principal = Sheets("الرئيسية") Dim My_rg As Range lr = Sh_Principal.Cells(Rows.Count, 1).End(3).Row For I = 3 To Sheets.Count my_row = Sheets(I).Cells(Rows.Count, 1).End(3).Row ' Sheets(I).Range("a4:G" & my_row).ClearContents Sh_Principal.Range("a1").AutoFilter field:=1, Criteria1:=Sheets(I).Name Set My_rg = Sh_Principal.Range("a2:g" & lr).SpecialCells(12) my_row = Sheets(I).Cells(Rows.Count, 1).End(3).Row If my_row < 4 Then my_row = 4 If my_row = 4 Then My_rg.Copy Destination:=Sheets(I).Range("A4") Else My_rg.Copy Destination:=Sheets(I).Range("A" & my_row + 1) End If Next End Sub 1 رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر أغسطس 5, 2016 الكاتب مشاركة قام بنشر أغسطس 5, 2016 (معدل) اشكركم اخواني استاد سليم اشكرك هذا الكود لايعمل كما اريد يرحل جميع ما في الشيت الرءيسية حتى عناوين الاعمدة وتقيل بعض الشيء اظن انه بعد تعديل بسيط يكون افضل الكود الاول لاستاد ابو حنين يعمل جيدا كما اريد وارحل به 251 بيان في ظرف وجيز ربما بعد تعديله يكون احسن مما هو عليه شكرا لكم يا اساتدتنا الاعزاء تم تعديل أغسطس 5, 2016 بواسطه حسين22 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان