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

[عبد الله السعيد]

اريد تحويل العمودين A والعمود B الى الجدول المرفق

TTT.xlsx

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

جرب هذا الكود

Option Explicit
Sub Transfer_data()
Dim i%, m%: m = 4
Dim lrA%, My_text
Dim Wrd(), t%: t = 1
Dim k%, lRD%
Range("D4").Resize(500, 13).ClearContents
lrA = Cells(Rows.Count, "A").End(3).Row
For i = 4 To lrA Step 2
My_text = Trim(Range("b" & i))
 My_text = Split(My_text, " ")
  For k = LBound(My_text) To UBound(My_text)
   If My_text(k) <> vbNullString Then
     ReDim Preserve Wrd(1 To t)
     Wrd(t) = My_text(k)
     t = t + 1
    End If
    Next
 Range("D" & m) = Range("A" & i)
 Range("E" & m).Resize(1, UBound(Wrd) - LBound(Wrd) + 1) = Wrd
 m = m + 1
    Erase Wrd
   t = 1
 Next
 lRD = Cells(Rows.Count, "d").End(3).Row
 Range("D" & lRD + 1) = "TOTAL"
 Range("E" & lRD + 1).Resize(, 12).Formula = _
 "=SUM(E4:E" & lRD & ")"
End Sub

الصفحة  Salim من هذا الملف

TTT_salim.xlsm

[Ali Mohamed Ali]

حل وكود رائعان

احسنت أستاذ سليم بارك الله فيك

[عبد الله السعيد]

تم تنزيل الملف   ، وجربت احذف العمود او اعدل على المبالغ    لم يتغير الجدول

بالاضافة الى ان الاعمدة غير مجمعه المبالغ   ولم افهم هذا الجدول

تم تعديل يونيو 17, 2019 بواسطه عبد الله السعيد

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

 

لم تستعمل الماكرو كما يجب

في هذا الملف قم يتغيير  ما تريد ثم اضغط على الزر Run

 

 

 

 

TTT_salim_New.xlsm

[عبد الله السعيد]

السلام عليكم  اخي سليم

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

ولكن كما هو في الصور وكما ذكرت من قبل

لا يتم جمع الاعمدة كما هو مشار في الصورة

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

تحياتي لك
 

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

منذ ساعه, عبد الله السعيد said:

السلام عليكم  اخي سليم

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

ولكن كما هو في الصور وكما ذكرت من قبل

لا يتم جمع الاعمدة كما هو مشار في الصورة

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

تحياتي لك
 

تم معالجة الامر على هذا العنوان مشاركة رقم 4

http://excel-egy.com/forum/t3550

الملف من جديد

 

TTT_salim_New _Extra.xlsm

[عبد الله السعيد]

اشكرك على المتابعة والاهتمام

ولكن ياغالي اريد المجموع في الصف الاخير   كما هو مصمم في الجدول

اشكرك على المتابعة والاهتمام

ولكن ياغالي اريد المجموع في الصف الاخير   كما هو مصمم في الجدول

 

تم تعديل يونيو 19, 2019 بواسطه عبد الله السعيد

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

استبدل الماكرو بهذا

Option Explicit
Sub Transfer_data()
Dim i%, m%: m = 4
Dim lrA%, My_text
Dim Wrd(), t%: t = 1
Dim k%

Range("D4").Resize(500, 13).ClearContents
lrA = Cells(Rows.Count, "A").End(3).Row
For i = 4 To lrA
     If Range("A" & i) = vbNullString _
      Or Range("B" & i) = vbNullString Then
      GoTo NEXT_I
     End If
     My_text = Split(Range("b" & i), " ")
      For k = LBound(My_text) To UBound(My_text)
       If My_text(k) <> vbNullString Then
         ReDim Preserve Wrd(1 To t)
         Wrd(t) = Application.Substitute(My_text(k), ",", ".")
         Wrd(t) = IIf(IsNumeric(Wrd(t)), Wrd(t), 0)
         t = t + 1
        End If
       Next
   
    Range("D" & m) = Range("A" & i)
     Range("E" & m).Resize(1, UBound(Wrd) - LBound(Wrd) + 1) = Wrd
     m = m + 1
   
        Erase Wrd
       t = 1
NEXT_I:
 Next

 Range("D35") = "TOTAL"
 Range("E35").Resize(, 12).Formula = _
 "=SUM(E4:E34)"

End Sub

 

[Ali Mohamed Ali]

ابداع استاذ سليم كود ممتاز زادك الله من فضلك وغفر لك وجزاك الله كل خير

[عبد الله السعيد]

ماشاء الله

ولا اجمل ولا احلى ولا اروع من كده  استاذنا 

جزاك الله خيرا

وجعله في ميزان حسناتك