تعبئة المعادلات بالماكرو

[محمد عدنان]

السلام  عليكم

الماكرو التالي 

Sub MyFillDown()
Dim lr As Long
    With ThisWorkbook.Sheets("Table")
    
      lr = .Rows.Cells(Rows.Count, 2).End(xlUp).Row
        .Range("j11").Formula = "=IF(ISBLANK(I11),"""",IF(ISNUMBER(I11),ROUND((I11+H11)/2,0),"" - ""))"
        .Range("j11:j" & lr).FillDown
        .Range("j11:j" & lr).Value = .Range("j11:j" & lr).Value
        
       
        
    End With
End Sub

الكود يقوم بحساب المعدل لعمود واحد في الملف المرفق ما هو التعديل لحساب المعدل للاعمدة المضللة بحث يكون الكود مختصر و سريع 

و شكرا 

tabl12.xlsx

[محمد هشام.]

في 15‏/8‏/2022 at 14:49, محمد عدنان said:

بحث يكون الكود مختصر و سريع 

يمكنك استخدام الاكواد التالية :

Sub M_H_AverageColumns1()
Application.ScreenUpdating = False
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
j = 8
k = 9
l = 10
    Do Until j > 47
    For i = 11 To 55
    If (Cells(i, j).Value + Cells(i, k).Value) / 2 = 0 Then
    Cells(i, l).Value = ""
    Else
    Cells(i, l).Value = (Cells(i, j).Value + Cells(i, k).Value) / 2
    End If
    Next i
    j = j + 3
    k = k + 3
    l = l + 3
    Loop
    Application.ScreenUpdating = True
End Sub

او هدا 

Sub M_H_AverageColumns2()
Application.ScreenUpdating = False
For i = 8 To 49 Step 3
    Set u = Range(Cells(11, i + 2), Cells(55, i + 2))
    u.Value = Evaluate("=(" & Range(Cells(11, i), Cells(55, i)).Address & "+ " & Range(Cells(11, i + 1), Cells(55, i + 1)).Address & ")/2")
Next
Application.ScreenUpdating = True
End Sub

ولتفريغ نفس الاعمدة بمكنك استخدام الكود التالي 
Sub M_H_clearColumns()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Application.ScreenUpdating = False
j = 8
k = 9
l = 10
    Do Until j > 47
    For i = 11 To 55
    Cells(i, l).Value = ""
    Next i
    j = j + 3
    k = k + 3
    l = l + 3
    Loop
    Application.ScreenUpdating = True
End Sub

 

تمت اضافة الاكواد للملف المرفق

tabl12-M_H.xlsm

[محمد عدنان]

السلام عليكم 

الاستاذ @Mohamed Hicham  جزاك الله كل خير  

بس سؤال هل الماكرو يقوم بالعمل عتد اخر قيمة في العمود B  ? 

ليس شرط عند 55  ?

 

[محمد هشام.]

6 ساعات مضت, محمد عدنان said:

ليس شرط عند 55  ?

6 ساعات مضت, محمد عدنان said:

تفضل اخي اجعل الكود بهده الطريقة

Sub M_H_AverageColumns2()
Dim lr As Long
Application.ScreenUpdating = False
For i = 8 To 49 Step 3
lr = Cells(Rows.Count, 2).End(xlUp).Row
    Set u = Range(Cells(11, i + 2), Cells(lr, i + 2))
    u.Value = Evaluate("=(" & Range(Cells(11, i), Cells(lr, i)).Address & "+ " & Range(Cells(11, i + 1), Cells(lr, i + 1)).Address & ")/2")
Next
Application.ScreenUpdating = True
End Sub

 

 

tabl12-M_H.xlsm

[محمد عدنان]

جزاك الله كل خير استاذ @Mohamed Hicham