(تمت الاجابة) كيف يمكن جمع خلايا اى ملف بمجرد اضافته لفولدر بملف الاجمالى

[hsa100]

السلام عليكم

عندى ملف اجماليات ( total.xls) بفولدر معين

ويوجد اكتر من ملف اكسيل بنفس الفولدر (1 ، 2 ، 3 )

المطلوب

كيفية جمع الخلايا المتناظرة بكل الملفات الموجودة بهذا الفولدر بملف الاجماليات

بمعنى جمع كل خلايا A1 فى A1 بملف الاجماليات ، كل خلايا B1 فى B1 بملف الاجماليات وهكذا

وكذلك

عند اضافة ملف جديد (4) بهذا الفولدر يتم ايضا جمع الخلايا المتناظرة بالاسلوب السابق بملف الاجماليات ( دون تغيير بالكود )

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

New Folder.rar

وشكرا لكم اهتمامكم

[الـعيدروس]

السلام عليكم

استعين بهذا الكود

لكي يعمل معاك الكود اتبع التالي

أولا هذا السطر من الكود تحط فيه المسار كالتالي :

A_P = "C:\Documents and Settings\user\Desktop\جمع كل الشيتات\"

وهذا الجزء في الدالة الخلية التي سيتم جمع قيمتها في كل الفولدر في الشيت الاول

G_D = WB.Sheets(1).Range("A1")

وهذا الكود حطه في وحدة مودويل وجرب واخبرني بالنتيجة

Option Explicit

Sub ALI_PAT()

Dim A_P As String, Fil As String

Dim C_A As Range, A_Rng As Range, A_ROW As Long

'============================================================

'	   هنا تحط مسار المجلد

A_P = "C:\Documents and Settings\user\Desktop\جمع كل الشيتات\"

'

Fil = Dir(A_P & "*.xls")

Do Until Fil = ""

Set C_A = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1)

C_A = Fil

C_A.Offset(, 1) = G_D(A_P & Fil)

Fil = Dir

Loop

With Range("C1")

.Value = "المجموع لملفات الفولدر"

.Borders.Color = 40

.Interior.Color = RGB(250, 250, 210)

.Font.Bold = True

.Font.Size = 16

.Font.Name = "Traditional Arabic"

.Font.Color = 3

End With

A_ROW = Cells(Rows.Count, 2).End(xlUp).Row

Cells(2, 3).Formula = Evaluate("=SUM(B2:B" & A_ROW & ")")

Set A_Rng = Range([A1], [B1].End(xlDown).Offset(1, 0))

A_Rng.Clear

Columns("C:C").EntireColumn.AutoFit

Cells(2, 3).HorizontalAlignment = xlCenter

Cells(2, 3).VerticalAlignment = xlCenter: Cells(2, 3).Borders.Color = 40

End Sub

Private Function G_D(MyFile As String)

Dim WB As Workbook

Set WB = Workbooks.Open(MyFile)

'============================================================

'		 هنا الخلية التي ستم جمع قيمتها في كل الملفات

G_D = WB.Sheets(1).Range("A1")

WB.Close False

End Function

النتيجة تكون في الشيت النشط خلية C1 و C2

والسلام عليكم

تم تعديل ديسمبر 20, 2011 بواسطه alidroos

[hsa100]

الاخ الكريم alidroos

بتنفيذ الكود يقوم بسرد محتويات الخلايا بالملفات 1،2،3 فى ملف الاجماليات

وهذا ما لم اقصده

انما قصدت جمع الخلايا المتناظرة فى كل ملف ووضع الناتج فى ملف الاجماليات بالخلية المناظرة

وشكرا لك اهتمامك

تم تعديل ديسمبر 21, 2011 بواسطه hsa100

[الـعيدروس]

السلام عليكم

اخي الفاضل hsa100

انا تحايلت بمهمة الكود كي يودي النتيجة الذي تريدها

فأنت طلبك جمع قيمة خلية معينه في ملفات اكسل

فعمل الكود يقوم بجلب قيمة الخلية من كل ملفات اكسل التي في الفولدر

وفي الاخر يجمة تلك القيم في خلية C2

هل هكذا تم الطلب

أو ارجو منك التوضيح اكثر

[طارق محمود]

أخي العيدروس

أعتقد أن أخونا hsa100 يعني أن الخلية A1 في الملف المجمع يكون بها رقم يساوي A1 في الملف1+A1 في الملف2 وهكذا

أخي العزيز hsa100

من الأفضل تحديد مجال لعمل الكود مارأيك في A1::H20 مثلا

[hsa100]

أخي العيدروس

أعتقد أن أخونا hsa100 يعني أن الخلية A1 في الملف المجمع يكون بها رقم يساوي A1 في الملف1+A1 في الملف2 وهكذا

أخي العزيز hsa100

من الأفضل تحديد مجال لعمل الكود مارأيك في A1::H20 مثلا

اخى الكريم TareQ M

هذا ما قصدته بالفعل وليكن النطاق كما تفضلت

[طارق محمود]

السلام عليكم

بعد إذن اخي العيدروس

تفضل أخي المرفق

به ماطلبت

علي أساس أنه

(1) مجال عمل الكود هو في A1:H20 في جميع الملفات

(2) سنستخدم فقط البيانات الموجودة في الورقة النشطة

بمعني أنه مثلا الملف الثاني كان مغلق وهو علي الورقة2 فسيأخذ الكود منه بيانات الورقة2 وهكذا

إن كنت تريد غير ذلك فلابد من ضمان أن جميع الملفات بما فيها ملف التجميع يحتوون علي نفس عدد الورقات

وايضا ممكن التعديل لينقل الأوراق ذات الإسم المتشابه في نفس الإسم في ملف التجميع

ولكنه الآن يعمل مع الورقة النشطة فقط

فكرة العمل أنه سيفتح الملفات ويغلقها واحدا تلو الآخر ويخزن البيانات في متغير لديه

ثم يضع هذا المتغير أخيرا بالملف TOTAL

تفضل المرفق

Has100.rar

[hsa100]

اخى الكريم TareQ M

بتنفيذ الكود يتم اغلاق الملف total

وباعادة فتحه مره اخرى لا تظهر ايه اجماليات

TareQ M

(وايضا ممكن التعديل لينقل الأوراق ذات الإسم المتشابه في نفس الإسم في ملف التجميع)

TareQ M

اعتقد ان ذلك يمكن ان يكون افضل

واشكر لك اهتمامك

[طارق محمود]

السلام عليكم

أخي العزيز

معذرة

عدل الكود إلي

Sub SameCells()


On Error Resume Next

Dim Fil As String, A(99, 99) As Long

'============================================================

x = ActiveWorkbook.Name

Fil = Dir(ActiveWorkbook.Path & "\" & "*.xls")


Do Until Fil = ""

If Fil = x Then GoTo 10


	Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & Fil

	For cc = 1 To 8		 ' Columns A:H

		For rr = 1 To 20	' Rows

			A(rr, cc) = A(rr, cc) + Cells(rr, cc)

		Next rr

	Next cc

  ActiveWorkbook.Close

10

	Fil = Dir


Loop


		For cc = 1 To 8		 ' Columns A:H

		For rr = 1 To 20	' Rows

			Cells(rr, cc) = A(rr, cc)

		Next rr

	Next cc


End Sub

بمعني آخر ، إستبدل السطر

Workbooks.Open Filename:= Fil

بالتالي

   Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & Fil

أو المرفق بعد التعديل

TOTAL.rar

[hsa100]

اخى الكريم TareQ M

عمل ممتاز

اشكرك عظيم الشكر

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

تم تعديل ديسمبر 26, 2011 بواسطه hsa100

[hsa100]

الاخ الكريم طارق

هل من الممكن اضافة هذا التعديل الذى اقترحته فى الفقرة رقم 7

(وايضا ممكن التعديل لينقل الأوراق ذات الإسم المتشابه في نفس الإسم في ملف التجميع)

[طارق محمود]

السلام عليكم

تفضل أخي

هذا الكود بعد التعديل

Sub SameCells()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.DisplayAlerts = False


On Error Resume Next

Dim Fil As String, A(9, 99, 99, 99) As Long, nm(99, 99) As String


'============================================================

x = ActiveWorkbook.Name

Fil = Dir(ActiveWorkbook.Path & "\" & "*.xls")

wb = 0

Do Until Fil = ""

If Fil = x Then GoTo 10

	wb = wb + 1

	Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & Fil

	CN = Sheets.Count

		If mxCN < CN Then mxCN = CN


	For sh = 1 To CN

		nm(wb, sh) = Sheets(sh).Name

		For cc = 1 To 8		 ' Columns A:H

			For rr = 1 To 20	' Rows

				A(wb, sh, rr, cc) = Sheets(sh).Cells(rr, cc)

			Next rr

		Next cc

	Next sh


  ActiveWorkbook.Close

10

	Fil = Dir


Loop





For sh = 1 To Sheets.Count

	Sheets(sh).Range("A1:H20").ClearContents

	For w = 1 To wb

		For n = 1 To mxCN


			If nm(w, n) = Sheets(sh).Name Then

				For cc = 1 To 8		 ' Columns A:H

					For rr = 1 To 20	' Rows

						 Sheets(sh).Cells(rr, cc).Value = Sheets(sh).Cells(rr, cc).Value + A(w, n, rr, cc)

					Next rr

				Next cc


			GoTo 15

			End If


		Next n

15

	Next w

Next sh


Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Application.DisplayAlerts = True



End Sub

وهذا هو المجلد وبه ملفات مختلفة واوراق متشابهة الأسماء للتجربة

تفضل المرفق

Has100.rar

[hsa100]

اخى الكريم طارق

عمل أكثر من رائع

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

[abouelhassan]

استاذنا مهندس طارق

كل الشكر والاحترام والتقدير

من اخيك