أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





جمع ملفات اكسل في ملف واحد

السلام عليكم ...... لتسهيل عملية البحث عن الطالب ليكون في ملف واحد عندي ملفات مدارس كثيرة - تأتي من عدة مدارس - عند قيام ..


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


10-05-2020 10:02 مساء
علي ابوعبدالله
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 10-05-2020
رقم العضوية : 19146
المشاركات : 3
الجنس : ذكر
تاريخ الميلاد : 1-1-1967
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 14
 offline 

السلام عليكم ...... لتسهيل عملية البحث عن الطالب ليكون في ملف واحد
عندي ملفات مدارس كثيرة - تأتي من عدة مدارس - عند قيامي بالبحث عن طالب او طالبة يأخذ مني وقت 
اريد جمع هذه الملفات في ملف واحد  لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  ملف المدارس.rar   تحميل rar مرات التحميل :(10)
الحجم :(30.645) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
عادةً لا أضع أكثر من حل في موضوع واحد ولكن لأنك عضو جديد سأعتبر هذا استثناء
تفضل الكود التالي عله يفي بالغرض
Sub Test()
    Dim wb As Workbook, ws As Worksheet, sh As Worksheet, b As Boolean, sPath As String, myFile As String
    
    Set sh = ThisWorkbook.Worksheets(1)
    sPath = ThisWorkbook.Path & "\MyFiles\"
    myFile = Dir(sPath & "*.xls*")

    Application.ScreenUpdating = False
        Do While myFile <> ""
            If UCase(myFile) <> UCase(ThisWorkbook.Name) Then
                Set wb = Workbooks.Open(sPath & myFile, False)
    
                For Each ws In wb.Worksheets
                    If IsError(Evaluate("ISREF('[" & ThisWorkbook.Name & "]" & ws.Name & "'!A1)")) Then
                        If b = False Then ws.Rows(1).Copy sh.Rows(1): b = True
                        ws.Range("A1").CurrentRegion.Offset(1).Copy sh.Range("A" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                    End If
                Next ws
                wb.Close SaveChanges:=True
            End If
            myFile = Dir
        Loop
    Application.ScreenUpdating = True
End Sub
عرض الإجابة




10-05-2020 10:43 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif جمع ملفات اكسل في ملف واحد
وعليكم السلام أخي الكريم وأهلاً بك في المنتدى
يراعى عند طرح مشكلة أن تكون المشكلة واضحة وترفق صورة لشكل النتائج المتوقعة
أنت تريد جمع البيانات في ملف واحد وتركت الموضوع مفتوح .. قد يكون الموضوع نسخ لأوراق العمل كلها من الملفات المغلقة ووضعها كل ورقة لوحدها في المصنف الذي سيوضع فيه الكود .. وقد يكون تجميع البيانات لورقة العمل الأولى فقط من الملفات المغلقة ووضعها كلها في ورقة واحدة .. وقد يكون التجميع لأعمدة محددة وليس لكل البيانات
لذا يراعى الدقة في طرح الموضوعات

عموماً جرب الكود التالي 
قم بإنشاء مجلد باسم MyFiles وضع فيه الملفات ، وأنشيء ملف إكسيل رئيسي يوضع فيه الكود خارج المجلد في نفس المسار ونفذ الكود
Sub Test()
    Dim wb As Workbook, ws As Worksheet, sPath As String, myFile As String

    sPath = ThisWorkbook.Path & "\MyFiles\"
    myFile = Dir(sPath & "*.xls*")

    Application.ScreenUpdating = False
        Do While myFile <> ""
            If UCase(myFile) <> UCase(ThisWorkbook.Name) Then
                Set wb = Workbooks.Open(sPath & myFile, False)
    
                For Each ws In wb.Worksheets
                    If IsError(Evaluate("ISREF('[" & ThisWorkbook.Name & "]" & ws.Name & "'!A1)")) Then
                        ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                    End If
                Next ws
                wb.Close SaveChanges:=True
            End If
            myFile = Dir
        Loop
    Application.ScreenUpdating = True
End Sub

10-05-2020 11:12 مساء
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif جمع ملفات اكسل في ملف واحد
أحسن الله إليك أخي العزيز علي ومشكور على متابعتك المستمرة

10-05-2020 11:18 مساء
مشاهدة مشاركة منفردة [3]
علي ابوعبدالله
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 10-05-2020
رقم العضوية : 19146
المشاركات : 3
الجنس : ذكر
تاريخ الميلاد : 1-1-1967
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 14
 offline 
look/images/icons/i1.gif جمع ملفات اكسل في ملف واحد

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

السلام عليكم - جزيت خيرا والله يعوض عليك على الجهد 
اخي : طلبي هو جمع الملفات في ملف واحد (كل ملفات المدارس تكون في صفحة واحدة
كما وضحت الفكرة بالملف المرفق كما طلبت مني ايضاح النتائج المطلوبة 
 
 
 
  جمع الملفات.rar   تحميل rar مرات التحميل :(9)
الحجم :(11.034) KB


11-05-2020 12:28 صباحا
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif جمع ملفات اكسل في ملف واحد
عادةً لا أضع أكثر من حل في موضوع واحد ولكن لأنك عضو جديد سأعتبر هذا استثناء
تفضل الكود التالي عله يفي بالغرض
Sub Test()
    Dim wb As Workbook, ws As Worksheet, sh As Worksheet, b As Boolean, sPath As String, myFile As String
    
    Set sh = ThisWorkbook.Worksheets(1)
    sPath = ThisWorkbook.Path & "\MyFiles\"
    myFile = Dir(sPath & "*.xls*")

    Application.ScreenUpdating = False
        Do While myFile <> ""
            If UCase(myFile) <> UCase(ThisWorkbook.Name) Then
                Set wb = Workbooks.Open(sPath & myFile, False)
    
                For Each ws In wb.Worksheets
                    If IsError(Evaluate("ISREF('[" & ThisWorkbook.Name & "]" & ws.Name & "'!A1)")) Then
                        If b = False Then ws.Rows(1).Copy sh.Rows(1): b = True
                        ws.Range("A1").CurrentRegion.Offset(1).Copy sh.Range("A" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                    End If
                Next ws
                wb.Close SaveChanges:=True
            End If
            myFile = Dir
        Loop
    Application.ScreenUpdating = True
End Sub

11-05-2020 12:47 صباحا
مشاهدة مشاركة منفردة [5]
ali mohamed ali
مشرف على منتدى الاكسيل
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 1769
الدولة : مصر
الجنس : ذكر
الدعوات : 2
يتابعهم : 0
يتابعونه : 68
قوة السمعة : 9642
عدد الإجابات: 47
 offline 
look/images/icons/i1.gif جمع ملفات اكسل في ملف واحد
تمام استاذ ياسر بارك الله فيك
استاذ علي ابوعبدالله ,انت محظوظ جدا فتم تنفيذ طلبك بطريقتين مختلفتين وعمل كودين مختلفين
فبكده ليس هناك اى حجة اخرى لك فى هذا الموضوع وتم على اكمل وجه والبركة طبعا والفضل بعد ربنا لأستاذنا الغالى ياسر خليل له منا جميعا كل المحبة والإحترام وبارك الله فى اولاده ووسع الله فى رزقه وأكرمه الله فى الدارين
توقيع :ali mohamed ali
{ وَقُل رَّبِّ زِدْنِي عِلْمًا }
[ كن على يقين من اعمالنا نخطئ ومن اخطائنا نتعلم ولذلك لا شي مستحيل ]
ساهم دائماً فى حل أى مشكلة او أستفسار لديك مع إضافة رد بشكره
أو دعوة لمن قدم اليك المساعدة,فالجميع هنا يعمل على مساعدة
 الاخرين لوجه الله وان تحتسب له اجر عند الله

11-05-2020 01:58 صباحا
مشاهدة مشاركة منفردة [6]
علي ابوعبدالله
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 10-05-2020
رقم العضوية : 19146
المشاركات : 3
الجنس : ذكر
تاريخ الميلاد : 1-1-1967
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 14
 offline 
look/images/icons/i1.gif جمع ملفات اكسل في ملف واحد
فعلاً اني محظوظ استاذ علي
اشكرك استاذ ياسر
هذا هو المطلوب
جزيتم خيرا


الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
ملفات ، اكسل ، واحد ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:24 مساء