هل ممكن جمع خليه معينة من ملفات اكسل مختلفه فى فولدر واحد؟

**علي الشيخ** · أكتوبر 2, 2012

السلام عليكم ورحمة الله وبركاته .... مرحبا اخواني ربنا يجزاكم الخير على المجهود المبذول في المنتدى المحترم .... استفساري هو بخصوص ان احد الاخوه الاخ عبدالله المجرب جزاه الله خيرا على مجهود ... كان عامل كود بيرحل في فولدر مستقل بيرحل مثلا فواتير مشروع معين الى فولدر باسم المشروع استفساري هنا لو في امكانية انى مثلا اعمل شيت يجمع اجمالي الفواتير دى من الشيتات اللى بتنشا في الفولدر ده مع العلم ان الفولدر ممكن يكون فيه شيت واحد وممكن 100 شيت انا مش عارف لانه بيكون على حساب العمل فاذا فيه كود يجمع من الشيتات دى نفس الخلية في كل شيت يكون جزاه الله خيرا

**أبو حنــــين** · أكتوبر 2, 2012

السلام عليكم

هناك ملف اسمع Book5 و هو الملف الرئيسي

و عناك مجلد اسمه RR يحتوي على ملفات كب في الخلية A1 من ك ملف العدد 1000

عند فتح الملف الرئسي تصغط على احسب يقوم بجلب البيانات من هذه الخلية ثم يجمعها في الخلية E1

مثال.rar

**علي الشيخ** · أكتوبر 3, 2012

عليكم السلام...

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

هو الفكره اللى انا عاوزها تمام بس في مشكلة لما اجي افتح المثال بتاعك

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

يكون الكود التالي باللون الاصفر

Set Files = Application.FileSearch

وما بقدر اجمع او اعمل شئ لان لما اضغط احسب ما يسوي شئ

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

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

**أبو حنــــين** · أكتوبر 3, 2012

السلام عليكم

بالنسبة للسؤال الاول ضع في بداية الكود الذي توقف عنده البرنامج الجملة التالية :

On Error Resume Next

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

بالنسبة للسؤال الثاني فهو يقوم بجمع 10 ملفات فقط لاننا وضعنا الشرط :

For i = 1 To .FoundFiles.Count

و عندما نريد اكثر من 10 نغير العدد 10 الى اي عدد تريد

ملاحظة

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

انا اعمل على اوفيس 2003 و لا ادري ان كان الكود يعمل على اصدار اكبر او لا

تحياتي اخي

**علي الشيخ** · أكتوبر 3, 2012

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

الله يجزاك كل خير وتاعبك معايا ربنا يكرمك

انا اضفت الكود واختفت المسج بس ما بيجمع ظهرلي 0 في الخلية بس عشان مش بيظهر اسماء الشيتات زي ما حضرتك قولت

وانا اشتغل على اوفيس 2010

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

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

**أبو حنــــين** · أكتوبر 3, 2012

اخي والله الكود عندي يعمل بشكل طبيعي لكن جرب التالي

ـ 1 ) كون مجلد و سمه RR و ضع فيه ملغات شرط ان تكتب في الخلية A1 من كل ملف قيمة معينة

ـ 2 ) انشأ مجلدا آخر و ضع فيه المجلد السابق

ـ 3 ) انشأ ملف اكسل ثم افتحه

ـ 4 ) اذهب الى محرر VB ثم اضف موديل و انسخ فيه الموديل التالي :


Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _

(ByVal lpRootPath As String, _

ByVal lpInputName As String, _

ByVal lpOutputName As String) As Long

Public Const MAX_PATH = 260

Public Function FindFile(RootPath As String, _

FileName As String) As String

Dim lNullPos As Long

Dim lResult As Long

Dim sBuffer As String

On Error GoTo FileFind_Error

sBuffer = Space(MAX_PATH * 2)

lResult = SearchTreeForFile(RootPath, FileName, sBuffer)

If lResult Then

lNullPos = InStr(sBuffer, vbNullChar)

If Not lNullPos Then

sBuffer = Left(sBuffer, lNullPos - 1)

End If

FindFile = sBuffer

Else

FindFile = vbNullString

End If

Exit Function

FileFind_Error:

FindFile = vbNullString

End Function

ـ 5 ) اذهب الى صفحة Workbook و افتحها و انسخ الكود الاتالي في الحدث Workbook_Open الكود :


Private Sub Workbook_Open()

ورقة1.Range("A1:A50").ClearContents

Set Files = Application.FileSearch

With Files

.LookIn = ThisWorkbook.Path + "\RR"

.FileName = "*.xls"

If .Execute > 0 Then

For i = 1 To .FoundFiles.Count

ورقة1.Cells(i + 1, 1) = .FoundFiles(i)

Next i

Else

MsgBox "لا يوجد ملفات في المسار" & vbNewLine & ThisWorkbook.Path + "\F", vbInformation, "خطأ"

End If

End With

End Sub

ـ 6 ) أنشأ في الصفحة الاولى من الملف زر و قم بنسخ الكود التالي في هذا الزر :


Private Sub CommandButton1_Click()

LastRow = Cells(Rows.Count, "D").End(xlUp).Row '+ 1

On Error Resume Next

Dim xl As New Excel.Application

Dim xlw As Excel.Workbook

Dim Vr As String

Vr = ThisWorkbook.Path & "\RR"

For n = 1 To 10

Set xlw = xl.Workbooks.Open(Cells(n + 1, 1))

xlw.ورقة1.Range("A1").Select

Cells(LastRow + n, 4).Value = xlw.Application.Range("A1").Value

xlw.Close False

Next

LR = Cells(Rows.Count, "D").End(xlUp).Row

For t = 1 To LastRow

s = LR

Cells(1, 5).Formula = "=Sum(D1:D" & s & ")"

Next

End Sub

الآن احفظ الملف في المجلد الثاني الذي أنشأته و اخرج منه ثم اعد فتحه من جديد فإن وجدت في الصفحة الاولى اسماء الملفات التي وضعتها في المجلد RR فالعمل صحيح ما بقي الا الضغط على الزر

و ان لم تجد . . . . . . . فالله اعلم بالخطأ الذي وقع

**عبدالله باقشير** · أكتوبر 4, 2012

السلام عليكم

الكود التالي يعمل على 2003-2007


Option Explicit

'//////////////////////////////////////////////////////


'  اسم مجلد الملفات

Const FilName As String = "ملفاتي"

'  عنوان خلية الجمع في الملفات

Const Adr As String = "A1"

'//////////////////////////////////////////////////////


Sub kh_SumAllBook()

Dim MyObj, MyObjFol, Obj

Dim xlw As Excel.Workbook

Dim MySheet As Worksheet

Dim iPath As String, iName As String

Dim Last As Long, i As Long

Dim ch As String * 1

ch = Application.PathSeparator

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

On Error GoTo Err_kh_Files

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

iPath = ActiveWorkbook.Path & ch & FilName & ch

Set MyObj = CreateObject("Scripting.FileSystemObject")

Set MyObjFol = MyObj.GetFolder(iPath)

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

Set MySheet = ThisWorkbook.Worksheets("TOTAL")

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

With MySheet

    Last = .Cells(Rows.Count, "A").End(xlUp).Row

    .Range("A2").Resize(Last, 3).ClearContents

End With

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

kh_Application False

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

On Error Resume Next

For Each Obj In MyObjFol.Files

    iName = Obj.Path

    If Not Dir(Obj.Path) = "" Then

        If TestType(CStr(Obj.Name)) Then

            Set xlw = Workbooks.Open(iName)

            With MySheet

                i = i + 1

                .Cells(i + 1, "A").Value = CStr(Obj.Name)

                .Cells(i + 1, "B").Value = CStr(xlw.Worksheets(1).Name)

                .Cells(i + 1, "C").Value = Val(xlw.Worksheets(1).Range(Adr))

            End With

            xlw.Close False

        End If

    End If

Next

On Error GoTo 0

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

If i Then MySheet.Range("E2").Value = Evaluate("Sum(" & Range("C2").Resize(i).Address & ")")

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

Err_kh_Files:

kh_Application True

If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear

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

Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing


End Sub


Sub kh_Application(mbol As Boolean)

With Application

    .Calculation = IIf(mbol, -4105, -4135)

    .ScreenUpdating = mbol

    .EnableEvents = mbol

End With

End Sub


Function TestType(MyTName As String) As Boolean

Dim MyTyp As String

MyTyp = Mid$(MyTName, InStrRev(MyTName, "."))

TestType = MyTyp Like ".xls*"

End Function

المرفق 2003-2007

kh_sum.rar

**علي الشيخ** · أكتوبر 4, 2012

اخي والله الكود عندي يعمل بشكل طبيعي لكن جرب التالي

ـ 1 ) كون مجلد و سمه RR و ضع فيه ملغات شرط ان تكتب في الخلية A1 من كل ملف قيمة معينة

ـ 2 ) انشأ مجلدا آخر و ضع فيه المجلد السابق

ـ 3 ) انشأ ملف اكسل ثم افتحه

ـ 4 ) اذهب الى محرر VB ثم اضف موديل و انسخ فيه الموديل التالي :
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _

(ByVal lpRootPath As String, _

ByVal lpInputName As String, _

ByVal lpOutputName As String) As Long

Public Const MAX_PATH = 260

Public Function FindFile(RootPath As String, _

FileName As String) As String

Dim lNullPos As Long

Dim lResult As Long

Dim sBuffer As String

On Error GoTo FileFind_Error

sBuffer = Space(MAX_PATH * 2)

lResult = SearchTreeForFile(RootPath, FileName, sBuffer)

If lResult Then

lNullPos = InStr(sBuffer, vbNullChar)

If Not lNullPos Then

sBuffer = Left(sBuffer, lNullPos - 1)

End If

FindFile = sBuffer

Else

FindFile = vbNullString

End If

Exit Function

FileFind_Error:

FindFile = vbNullString

End Function
ـ 5 ) اذهب الى صفحة Workbook و افتحها و انسخ الكود الاتالي في الحدث Workbook_Open الكود :
Private Sub Workbook_Open()

ورقة1.Range("A1:A50").ClearContents

Set Files = Application.FileSearch

With Files

.LookIn = ThisWorkbook.Path + "\RR"

.FileName = "*.xls"

If .Execute > 0 Then

For i = 1 To .FoundFiles.Count

ورقة1.Cells(i + 1, 1) = .FoundFiles(i)

Next i

Else

MsgBox "لا يوجد ملفات في المسار" & vbNewLine & ThisWorkbook.Path + "\F", vbInformation, "خطأ"

End If

End With

End Sub
ـ 6 ) أنشأ في الصفحة الاولى من الملف زر و قم بنسخ الكود التالي في هذا الزر :
Private Sub CommandButton1_Click()

LastRow = Cells(Rows.Count, "D").End(xlUp).Row '+ 1

On Error Resume Next

Dim xl As New Excel.Application

Dim xlw As Excel.Workbook

Dim Vr As String

Vr = ThisWorkbook.Path & "\RR"

For n = 1 To 10

Set xlw = xl.Workbooks.Open(Cells(n + 1, 1))

xlw.ورقة1.Range("A1").Select

Cells(LastRow + n, 4).Value = xlw.Application.Range("A1").Value

xlw.Close False

Next

LR = Cells(Rows.Count, "D").End(xlUp).Row

For t = 1 To LastRow

s = LR

Cells(1, 5).Formula = "=Sum(D1:D" & s & ")"

Next

End Sub
الآن احفظ الملف في المجلد الثاني الذي أنشأته و اخرج منه ثم اعد فتحه من جديد فإن وجدت في الصفحة الاولى اسماء الملفات التي وضعتها في المجلد RR فالعمل صحيح ما بقي الا الضغط على الزر

و ان لم تجد . . . . . . . فالله اعلم بالخطأ الذي وقع

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

السلام عليكم

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

جربت اعدل عليه اى شئ عشان يشتغل معايا على اوفيس 2010 بس ما قدرت تقريبا

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

هجربة على اوفيس 2007 لو اشتغل معايا يبقى حل المشكلة برضو وربنا يجزاك الف خير

**علي الشيخ** · أكتوبر 4, 2012

السلام عليكم

الكود التالي يعمل على 2003-2007


Option Explicit

'//////////////////////////////////////////////////////


'  اسم مجلد الملفات

Const FilName As String = "ملفاتي"

'  عنوان خلية الجمع في الملفات

Const Adr As String = "A1"

'//////////////////////////////////////////////////////


Sub kh_SumAllBook()

Dim MyObj, MyObjFol, Obj

Dim xlw As Excel.Workbook

Dim MySheet As Worksheet

Dim iPath As String, iName As String

Dim Last As Long, i As Long

Dim ch As String * 1

ch = Application.PathSeparator

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

On Error GoTo Err_kh_Files

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

iPath = ActiveWorkbook.Path & ch & FilName & ch

Set MyObj = CreateObject("Scripting.FileSystemObject")

Set MyObjFol = MyObj.GetFolder(iPath)

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

Set MySheet = ThisWorkbook.Worksheets("TOTAL")

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

With MySheet

    Last = .Cells(Rows.Count, "A").End(xlUp).Row

    .Range("A2").Resize(Last, 3).ClearContents

End With

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

kh_Application False

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

On Error Resume Next

For Each Obj In MyObjFol.Files

    iName = Obj.Path

    If Not Dir(Obj.Path) = "" Then

        If TestType(CStr(Obj.Name)) Then

            Set xlw = Workbooks.Open(iName)

            With MySheet

                i = i + 1

                .Cells(i + 1, "A").Value = CStr(Obj.Name)

                .Cells(i + 1, "B").Value = CStr(xlw.Worksheets(1).Name)

                .Cells(i + 1, "C").Value = Val(xlw.Worksheets(1).Range(Adr))

            End With

            xlw.Close False

        End If

    End If

Next

On Error GoTo 0

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

If i Then MySheet.Range("E2").Value = Evaluate("Sum(" & Range("C2").Resize(i).Address & ")")

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

Err_kh_Files:

kh_Application True

If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear

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

Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing


End Sub


Sub kh_Application(mbol As Boolean)

With Application

    .Calculation = IIf(mbol, -4105, -4135)

    .ScreenUpdating = mbol

    .EnableEvents = mbol

End With

End Sub


Function TestType(MyTName As String) As Boolean

Dim MyTyp As String

MyTyp = Mid$(MyTName, InStrRev(MyTName, "."))

TestType = MyTyp Like ".xls*"

End Function

المرفق 2003-2007

kh_sum.rar

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

الله يكرمك ويزيدك علم ويجزاك خير على مساعدتك

ضبط معاي على 2010 وبيشتغل بشكل كويس وحضرتك والاستاذ ابو حنين كفيتوا ووفيتوا والبرنامجين وصلوني بالضبط للى محتاجة

جعله الله في ميزان حسناتكم

**عبدالله باقشير** · أكتوبر 4, 2012

الحمد لله رب العالمين

**أبوبسمله** · ديسمبر 9, 2014

السلام عليكم

الكود التالي يعمل على 2003-2007

Option Explicit
'//////////////////////////////////////////////////////

'  اسم مجلد الملفات
Const FilName As String = "ملفاتي"
'  عنوان خلية الجمع في الملفات
Const Adr As String = "A1"
'//////////////////////////////////////////////////////

Sub kh_SumAllBook()
Dim MyObj, MyObjFol, Obj
Dim xlw As Excel.Workbook
Dim MySheet As Worksheet
Dim iPath As String, iName As String
Dim Last As Long, i As Long
Dim ch As String * 1
ch = Application.PathSeparator
'============================
On Error GoTo Err_kh_Files
'============================
iPath = ActiveWorkbook.Path & ch & FilName & ch
Set MyObj = CreateObject("Scripting.FileSystemObject")
Set MyObjFol = MyObj.GetFolder(iPath)
'============================
Set MySheet = ThisWorkbook.Worksheets("TOTAL")
'============================
With MySheet
    Last = .Cells(Rows.Count, "A").End(xlUp).Row
    .Range("A2").Resize(Last, 3).ClearContents
End With
'============================
kh_Application False
'============================
On Error Resume Next
For Each Obj In MyObjFol.Files
    iName = Obj.Path
    If Not Dir(Obj.Path) = "" Then
        If TestType(CStr(Obj.Name)) Then
            Set xlw = Workbooks.Open(iName)
            With MySheet
                i = i + 1
                .Cells(i + 1, "A").Value = CStr(Obj.Name)
                .Cells(i + 1, "B").Value = CStr(xlw.Worksheets(1).Name)
                .Cells(i + 1, "C").Value = Val(xlw.Worksheets(1).Range(Adr))
            End With
            xlw.Close False
        End If
    End If
Next
On Error GoTo 0
'============================
If i Then MySheet.Range("E2").Value = Evaluate("Sum(" & Range("C2").Resize(i).Address & ")")
'============================
Err_kh_Files:
kh_Application True
If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear
'============================
Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing

End Sub

Sub kh_Application(mbol As Boolean)
With Application
    .Calculation = IIf(mbol, -4105, -4135)
    .ScreenUpdating = mbol
    .EnableEvents = mbol
End With
End Sub

Function TestType(MyTName As String) As Boolean
Dim MyTyp As String
MyTyp = Mid$(MyTName, InStrRev(MyTName, "."))
TestType = MyTyp Like ".xls*"
End Function

المرفق 2003-2007

kh_sum.rar

استاذى الكريم

جزاك الله عنا خير الجزاء ولى سؤال

لدى 50 ملف اكسل وبها خانات كثيره

هل يمكن زيادة A1 الى اكثر من A مثلا عندى A23 و A25 و b26

وزيادة E2 الى اكثر من E ليتم الجمع فيهم

ان شاء الله يكون سؤالى واضح

ياسر خليل أبو البراء · ديسمبر 9, 2014

تفضل أخي طالب العلم

هذا تعديل بسيط على كود العلامة الكبير عبد الله باقشير .. التعديل إضافة قيمة الخلية C1 ..

KH SUM YK.rar

**أبوبسمله** · ديسمبر 12, 2014

تفضل أخي طالب العلم

هذا تعديل بسيط على كود العلامة الكبير عبد الله باقشير .. التعديل إضافة قيمة الخلية C1 ..

بارك الله فيك وجزاكم الله عنا خير الجزاء

تسجيل الدخول

هل ممكن جمع خليه معينة من ملفات اكسل مختلفه فى فولدر واحد؟

الردود الموصى بها

علي الشيخ

أبو حنــــين

علي الشيخ

أبو حنــــين

علي الشيخ

أبو حنــــين

عبدالله باقشير

علي الشيخ

علي الشيخ

عبدالله باقشير

أبوبسمله

ياسر خليل أبو البراء

أبوبسمله

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information