بومتعب قام بنشر سبتمبر 3, 2016 مشاركة قام بنشر سبتمبر 3, 2016 السلام عليكم ورحمة الله وبركاته لدي ارقام متوزعه في اكثر من خليه في الاكسل وارغب بترتيبها في عمود واحد مرفق لكم الاكسل والنتيجة المطلوبه Book 115.rar رابط هذا التعليق شارك More sharing options...
أبو حنــــين قام بنشر سبتمبر 3, 2016 مشاركة قام بنشر سبتمبر 3, 2016 السلام عليكم جرب هذا الكود Private Sub CommandButton1_Click() Dim cel As Range, LR As Integer, x As Integer LR = ActiveSheet.UsedRange.Rows.Count x = 2 For Each cel In Range("A1:I" & LR) If IsEmpty(cel) = False Then Cells(x, 12) = cel.Value x = x + 1 End If Next cel End Sub رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر سبتمبر 3, 2016 مشاركة قام بنشر سبتمبر 3, 2016 بعد اذن اخي ابو حنين ربما هذا الكود اسرع قليلاً للبيانات الكبيرة Sub salim() Dim cel As Range, LR As Integer, x As Integer LR = ActiveSheet.UsedRange.Rows.Count Range("L2:l5000").Clear Set my_rg = Range("A1:I" & LR).SpecialCells(2, 23) Range("L2").Activate For Each my_cel In my_rg ActiveCell = my_cel ActiveCell.Offset(1, 0).Activate Next Range("L1").Activate End Sub رابط هذا التعليق شارك More sharing options...
قلم-الاكسل(عبدالعزيز) قام بنشر سبتمبر 10, 2016 مشاركة قام بنشر سبتمبر 10, 2016 ما يعجبني في المنتدى الكبير طرح عدة اجابات لموضوع واحد وهذا جهد يشكر عليه الاستاذ سليم والاستاذ ابوحنين ما شاء الله كعادتكما مبدعين رابط هذا التعليق شارك More sharing options...
بومتعب قام بنشر سبتمبر 10, 2016 الكاتب مشاركة قام بنشر سبتمبر 10, 2016 نرجو الافاده بكيفيه استعماال الكود وانا جربت طريقه CTRL+G ثم اخترت الفراغات وسويت عمليه حذف ثم نسخت الارقام تحت عمود واحد ابغى طريقه اسرع رابط هذا التعليق شارك More sharing options...
أبو حنــــين قام بنشر سبتمبر 10, 2016 مشاركة قام بنشر سبتمبر 10, 2016 مرحبا هذه طريقة اسرع تتوافق مع الملف الذي ارسلته ضع هذا الكود في موديل و انشئ زر و اربطه بهذا الكود Sub RegroupValue() Range("L2:L" & Cells(Rows.Count, 12).End(3).Row).ClearContents Dim Rng, nCells, c, MyObject As Object, LR As Long Application.ScreenUpdating = False LR = ActiveSheet.UsedRange.Rows.Count Set MyObject = CreateObject("Scripting.Dictionary") Rng = Range("A1:i" & LR).Value For Each c In Rng If c <> "" Then MyObject(c) = c Next c nCells = MyObject.Keys Range("l2").Resize(MyObject.Count, 1) = Application.Transpose(nCells) Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
قلم-الاكسل(عبدالعزيز) قام بنشر سبتمبر 10, 2016 مشاركة قام بنشر سبتمبر 10, 2016 وهذه مساعدة مني حيث قمت بوضع زر "اضغط "كي يكون عليك سهل Book 115.rar 1 رابط هذا التعليق شارك More sharing options...
بومتعب قام بنشر أكتوبر 8, 2016 الكاتب مشاركة قام بنشر أكتوبر 8, 2016 (معدل) في ١٠/٩/٢٠١٦ at 14:32, قلم-الاكسل(عبدالعزيز) said: وهذه مساعدة مني حيث قمت بوضع زر "اضغط "كي يكون عليك سهل Book 115.rar ماقصرت حبيبي هل يمكن جعل المعادله بعدد غير محدود من الاعمده ...؟ تم تعديل أكتوبر 8, 2016 بواسطه بومتعب رابط هذا التعليق شارك More sharing options...
قلم-الاكسل(عبدالعزيز) قام بنشر أكتوبر 9, 2016 مشاركة قام بنشر أكتوبر 9, 2016 (معدل) عسى المهندس المبدع الاستاذ ابو حنين يفيدك ف الموضوع لانه من اكثر المبدعين ف الاكواد تم تعديل أكتوبر 9, 2016 بواسطه قلم-الاكسل(عبدالعزيز) رابط هذا التعليق شارك More sharing options...
أبو حنــــين قام بنشر أكتوبر 9, 2016 مشاركة قام بنشر أكتوبر 9, 2016 السلام عليكم يصبح شكل الكود كالتالي Private Sub CommandButton1_Click() Application.ScreenUpdating = False ActiveSheet.UsedRange.Rows.Select Range("L2:L" & Cells(Rows.Count, 12).End(3).Row).ClearContents Dim Rng, nCells, c, MyObject As Object, LR As Long LR = ActiveSheet.UsedRange.Rows.Count Set MyObject = CreateObject("Scripting.Dictionary") Rng = Selection.Value For Each c In Rng If c <> "" Then MyObject(c) = c Next c nCells = MyObject.Keys Range("l2").Resize(MyObject.Count, 1) = Application.Transpose(nCells) Range("l2").Select Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان