احتاج تحويل هذه المعادلات إلى أكواد للتخلص من ثل الملفات

[Khorsheed Omar]

مساء الخير جميعاً 

لدي ملف اكسل و به العديد من الشيتات و الكثير من المعادلات في كل شيت و الملف المرفق مثال عنه

احتاج أن احول المعادلات إلى أكواد VBA للتخلص من ثقل الملفات و لكم جزيل الشكر 

مصنف.xlsm

[abouelhassan]

جرب

Function GetCustomerData(customerCode As String, dataSheet As Worksheet) As Variant
    Dim dataRange As Range
    Dim result As Variant
    
    Set dataRange = dataSheet.Range("A:C")
    result = Application.WorksheetFunction.Index(dataRange.Columns(3), _
                Application.WorksheetFunction.Match(1, (dataRange.Columns(1) = [E1]) * (dataRange.Columns(2) = customerCode), 0))
    
    GetCustomerData = IIf(customerCode = "", "", result)
End Function

Function GetCustomerTotal(customerCode As String, dataSheet As Worksheet) As Variant
    Dim dataRange As Range
    Dim result As Variant
    
    Set dataRange = dataSheet.Range("A:D")
    result = Application.WorksheetFunction.SumIfs(dataRange.Columns(4), dataRange.Columns(1), [E1], dataRange.Columns(2), customerCode)
    
    GetCustomerTotal = IIf(customerCode = "", "", result)
End Function

 

[Khorsheed Omar]

شكرا لك استاذ @abouelhassan

لكن لم يعمل الكود بشكل جيد بعد تغيير اسماء الأعمدة أيضاً 

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

و ايضا لا ارغب بتغيير اسماء الشيتات لأنها ستكون ثابتة

[abouelhassan]

الكود يعمل اخى ما تقوم بها المعادلات

تحياتي 

[Khorsheed Omar]

عفوا استاذ @abouelhassan

لكن هل يمكنك تطبيقها على الملف كي اعرف بالضبط ما انا مخطئ فيه

[محمد هشام.]

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

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

Sub sheets_arrformula()

'Execute On All Worksheets

Dim wsName As Worksheet, desWS As Worksheet
Dim lr As Long, lige As Long
Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية")

For Each wsName In ThisWorkbook.Worksheets
If wsName.Name Like "*-JAN" Then

'في حالة اظافة اوراق اخرى للمصنف

'Example February March..........   1-Feb ,2-Feb.......1-Mar ,2-Mar

'If wsName.Name Like "*-*" Then

With Application
    .ScreenUpdating = False
    .Calculation = xlManual
 
Set desWS = ThisWorkbook.Sheets(wsName.Name)
lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr)
        Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr)
        f = ws.Name

lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
                                               desWS.Range("B2:C" & lige).ClearContents

With desWS.Range("B2:B" & lige)
.Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")"
  .Value = .Value

With desWS.Range("C2:C" & lige)
.Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")"
   .Value = .Value
  
                End With
             End With
       .ScreenUpdating = True
    .Calculation = xlAutomatic
       End With
    End If
Next wsName
End Sub

ولتنفيد الكود على الورقة النشطة 

Sub Test2()
'Execute On the Active Worksheet
Dim lr As Long, lige As Long
Dim ws As Worksheet: Set ws = Sheets("بيانات رئيسية")
Dim desWS As Worksheet: Set desWS = ActiveSheet

With Application
    .ScreenUpdating = False
    .Calculation = xlManual
lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
f = ws.Name
Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr)
Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr)
If desWS.Name <> f Then

lr = ws.Columns("A:D").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        Set a = ws.Range("A2:A" & lr): Set b = ws.Range("B2:B" & lr)
        Set c = ws.Range("C2:C" & lr): Set d = ws.Range("D2:D" & lr)
        f = ws.Name

lige = desWS.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
                                               desWS.Range("B2:C" & lige).ClearContents

With desWS.Range("B2:B" & lige)
.Formula2 = "=IFERROR(INDEX('" & f & "'!" & c.Address & ",MATCH(1,(E$1 ='" & f & "'!" & a.Address & ")*(A2 ='" & f & "'!" & b.Address & "),0)),"""")"
  .Value = .Value

With desWS.Range("C2:C" & lige)
.Formula2 = "=IF($B2<>"""",SUMIFS('" & f & "'!" & d.Address & ",'" & f & "'!" & a.Address & ",""=""&$E$1,'" & f & "'!" & c.Address & ",""=""&$B2,'" & f & "'!" & b.Address & ",a2),"""")"
  .Value = .Value
            End With
          End With
        End If
.ScreenUpdating = True
.Calculation = xlAutomatic
 End With
End Sub

 

مصنف v2.xlsm

تم تعديل فبراير 24 بواسطه محمد هشام.

[Khorsheed Omar]

تمت شكرا جزيلاً