استفسار تجميع الارقام في عمود واحد

[بومتعب]

السلام عليكم ورحمة الله وبركاته 

لدي ارقام متوزعه في اكثر من خليه في الاكسل وارغب بترتيبها في عمود واحد 

مرفق لكم الاكسل والنتيجة المطلوبه 

 

 

Book 115.rar

[أبو حنــــين]

السلام عليكم

جرب هذا الكود

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

 

[سليم حاصبيا]

بعد اذن اخي ابو حنين

ربما هذا الكود اسرع قليلاً للبيانات الكبيرة

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

 

[قلم-الاكسل(عبدالعزيز)]

ما يعجبني في المنتدى الكبير طرح عدة اجابات لموضوع واحد وهذا جهد يشكر عليه الاستاذ سليم والاستاذ ابوحنين

ما شاء الله كعادتكما مبدعين

[بومتعب]

نرجو الافاده بكيفيه استعماال الكود

وانا جربت طريقه CTRL+G 

ثم اخترت الفراغات وسويت عمليه حذف

ثم نسخت الارقام تحت عمود واحد 

ابغى طريقه اسرع

[أبو حنــــين]

مرحبا

هذه طريقة اسرع تتوافق مع الملف الذي ارسلته

ضع هذا الكود في موديل و انشئ زر و اربطه بهذا الكود

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

 

[قلم-الاكسل(عبدالعزيز)]

وهذه مساعدة مني حيث قمت بوضع زر "اضغط "كي يكون عليك سهل

 

 

Book 115.rar

[بومتعب]

في ١٠‏/٩‏/٢٠١٦ at 14:32, قلم-الاكسل(عبدالعزيز) said:

وهذه مساعدة مني حيث قمت بوضع زر "اضغط "كي يكون عليك سهل

 

 

Book 115.rar

ماقصرت حبيبي 

هل يمكن جعل المعادله بعدد غير محدود من الاعمده  ...؟

تم تعديل أكتوبر 8, 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