كود انشاء معادلة SUM لتجميع قيم من ملف اخر

[tlayt kamal]

الاخوة الكرام 

حياكم الله

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

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

الرئيسي.xlsxFetching info... تجميع.xlsmFetching info...

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

لحسن كتابة الكود ونسخه ولصقه تم العمل على
1- تغيير اسماء الملفات الى  (ALl_SUM /  تجميع   ) و  (Main /الرئيسي)

2- يجب ان يكون الملفان في نفس الــ  Folder
3- تغيير اسماء الضفحات الى Page2   Page1 .....    بدل 1/2/3/4
الكود 

Sub Get_From_Other_WB()
Dim mPath$
Dim F_Name, TS$, m%
Dim arr(), itm
arr = Array("Page1", "Page2", "Page3", "Page4")

m = 4

If UCase(ActiveSheet.Name) <> "TOTAL" Then GoTo BAY_BAY_YA_HILWEEN
With Sheets("TOTAL")
.Cells(4, "D").Resize(UBound(arr) + 1).ClearContents
  mPath = ThisWorkbook.Path & "\"

 For Each itm In arr
    F_Name = mPath & "[Main.xlsx]"
    F_Name = "='" & F_Name & itm & "'!B2"
    .Cells(m, "D").Formula = F_Name
    m = m + 1
    F_Name = ""
 Next
 .Cells(4, "D").Resize(UBound(arr) + 1).Value = _
 .Cells(4, "D").Resize(UBound(arr) + 1).Value
End With
BAY_BAY_YA_HILWEEN:

End Sub

الملفان مرفقان ضمن هذا الـــ Folder

ALl_SUM.xlsmFetching info...

Main.xlsxFetching info...

[tlayt kamal]

استاد سليم 

عمل رائع ولكن ادخال اسماء الشيتات في المتغير arr مرهق شيئا ما 

هل فيه طريقة اخرى لانه فيملف العمل الرئيسي 298 شيت ؟

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

و لما لم تقل ذلك مسبقاُ (جاري التعديل)

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

تم التعديل بحيث يقوم الماكرو باضافة الشيتات الى الــ   Array   اوتوماتيكياً

Sub Get_From_Other_WB()
Dim mPath$, OtherWB As Workbook
Dim F_Name, TS$, m%
Dim arr(), itm, x
'arr = Array("Page1", "Page2", "Page3", "Page4")
Application.ScreenUpdating = False
m = 4
mPath = ThisWorkbook.Path & "\"
mPath = mPath & "Main.xlsx"

Set OtherWB = Workbooks.Open(mPath)
 For i = 1 To OtherWB.Sheets.Count
  ReDim Preserve arr(i - 1)
  arr(i - 1) = OtherWB.Sheets(i).Name
 Next
 OtherWB.Close
If UCase(ActiveSheet.Name) <> "TOTAL" Then GoTo BAY_BAY_YA_HILWEEN
With Sheets("TOTAL")
.Cells(4, "D").Resize(UBound(arr) + 1).ClearContents
  mPath = ThisWorkbook.Path & "\"

 For Each itm In arr
    F_Name = mPath & "[Main.xlsx]"
    F_Name = "='" & F_Name & itm & "'!B2"
    .Cells(m, "D").Formula = F_Name
    m = m + 1
    F_Name = ""
 Next
 .Cells(4, "D").Resize(UBound(arr) + 1).Value = _
 .Cells(4, "D").Resize(UBound(arr) + 1).Value
End With
BAY_BAY_YA_HILWEEN:
Application.ScreenUpdating = True
End Sub

 

ALl_SUM_1.xlsmFetching info... Main.xlsxFetching info...

[tlayt kamal]

نعم استاد هذا ما اريد بالضبط

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