ترحيل ملفات إلى ملف واحد مغاير

[nakiramar]

السلام عليكم

أريد ترحيل مجموعة ملفات إكسل (كل واحد يحتوير على Data) وجلبها على شكل أوراق في ملف جديد باستعمال خاصية اختبار ملف .....

عفوا فأنا لا أعرف الكثير عن vba

PV.rar

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

وعليكم السلام أخي الكريم

أهلاً بك في المنتدى ونورت بين إخوانك

قم بإنشاء ملف إكسيل خارج المجلد المسمى PV وضع الكود التالي بداخله (اخفظ الملف بصيغة xlsm) 

Sub ImportDataFromClosedWBs()
    Dim wbk         As Workbook
    Dim strFolder   As String
    Dim strFile     As String
    Dim i           As Long

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
        strFolder = ThisWorkbook.Path & "\PV\"
        strFile = Dir(strFolder & "*.xls*")
    
        Do While strFile <> ""
            Set wbk = Workbooks.Open(strFolder & strFile)
    
            wbk.Sheets("Data").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            i = i + 1
            ActiveSheet.Name = "Data " & i
            wbk.Close False
            strFile = Dir
        Loop
    With Application
        .AskToUpdateLinks = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

 

[nakiramar]

والله  يا أخي المنتدى منور بكم

ألف شكر على المساعدة

طلب بسيط أظن عليكم

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

وعن الانتهاء يعود البرنامج إلى الورقة الأصلية Feuil1 في الملف الذي تم إنشاؤه

مع تحياتي

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

بسيطة أخي الكريم ... 

شيل السطر الخاص بالتسمية اللي هو دا

ActiveSheet.Name = "Data " & i

وضع مكانة السطر التالي

ActiveSheet.Name = wbk.Sheets("Data").Range("J7").Value

وبالنسبة للعودة إلى الورقة الأصلية استخدم الجملة التالية في نهاية الكود

Application.GoTo Feuil1.Range("A1")

 

[nakiramar]

الله يحفظك وينور عليك

[nakiramar]

شكرا جزيلا  أخي

لقد قمت بإنشاء زر على الصفحة الريسية وقمت بإعطائه الكود وهو يعمل بشكل جيد

لو أمكن أريد كود آخر لأجل حذف الأوراق التي تمت إضافتها عن طريق الكود الأول(من أجل التحديث)

مع تحياتي

 

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

بارك الله فيك أخي الكريم

أفضل طرح موضوع جديد لكل طلب ، قم بمراجعة التوجيهات في الموضوعات المثبتة في صدر المنتدى ..

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

 

[nakiramar]

والله أنا آسف

لم أكن أعرف

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

ولا يهمك أخي الكريم

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