توجيه المبلغ

[الدهشوري]

السلام عليكم ورحمة الله وبركاته ،،،، اعضاء هذا المنتدى الرائع وجزاكم الله كل خير علي ما تقدموه لخدمة البشرية وجعله الله في ميزان حسناتكم لى طلب اتمنى ان اجد الحل لديكم :

في العامود D المبلغ - ارغب في نقلة للاعمدة حسب التوجية الموجود بالعامود E

مثال: مبلغ 5000ج سلفة شخصية التوجية علي احمد جمال

اتمنى ان اكون قد وضحت الفكرة ولكم منى جزيل الشكر وفائق الاحترام ،،،،

 

توجيه المبلغ.xlsx

[Ali Mohamed Ali]

وعليكم السلام-فقط عليك استخدام هذه المعادلة

=IF($E3=$F$2:$AK$2,$D3,"")

 

توجيه المبلغ1.xlsx

[حسين مامون]

بعد اذن استاذي الكريم Ali Mohamed Ali

جرب الكود

Sub testttttttttt()
Dim x, y
Dim lr
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "e").End(3).Row
For x = 3 To lr
For y = 6 To 100
If Cells(x, "e").Text = Cells(2, y) Then
Cells(x, y).Value = Cells(x, "d").Value

End If
Next
Next
Application.ScreenUpdating = True

End Sub

 

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

بعد اذن اخي حسن مأمون

بواسطة هذا الكود تستطيع اختصار 94 حلقة تكرارية (y=6 to 100) في كل دورة من الـــ X من 1 الى Lr

اذن لوكان عدد الصفوف 100 صف فاننا نقوم بــ 94×100= 9400 حلقة تكرارية لا حاجه لها

يمكن هنا استعمال الدالة Match   او الدالة   Find لتحديد العامود الذي نريد الصاق قيمة الخلية المطلوب ولا حاجة للدورة ثانية من الحلقات التكراية(y)

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

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

هذا مثال عن الماكرو كما اتصوره هنا

Sub MY_code()
Dim x%, lr%, col%, Last_col%
Dim Find_cel As Range
Last_col = Cells(2, Columns.Count).End(1).Column
lr = Cells(Rows.Count, "e").End(3).Row
Range("F3").Resize(lr, Last_col - 5).Clear
For x = 3 To lr
    Set Find_cel = Rows(2).Find(Cells(x, "e"), lookat:=1)
    If Not Find_cel Is Nothing Then
     col = Find_cel.Column
     Cells(x, col) = Cells(x, "D")
    End If
 Next
    With Range("F3").Resize(lr, Last_col - 5).SpecialCells(2)
      .Borders.LineStyle = 1
      .Interior.ColorIndex = 6
      .Font.Bold = True
      .HorizontalAlignment = 3
    End With

End Sub

الملف مرفق

 

My_value.xlsm

[حسين مامون]

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

عمل رائع