نقل معلومات في عمود إلى مجموعة الملفات

[أبو محمد المنار]

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

 

اذا كان عندي مجموعة من الملفات و اريد أنقل لكل ملف معلومة من ملف آخر.

 

كما يلي : 

مجموعة الملفات ( محمد -احمد -سمير -ناصح- نبيل)

الملف الذي يحوي المعلومات هو xfile

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

 

ودمتم

files.zip

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

أخي الكريم المنار

إليك الكود التالي عله يفي بالغرض

Sub LoopThroughAllWorkbooks()
    Dim FolderPath As String, FileName As String, strWBName As String
    Dim WBK As Workbook
    Dim SH As Worksheet
    Dim X As Long, Cell As Range
    
    FolderPath = ThisWorkbook.Path & "\Files\"
    FileName = Dir(FolderPath & "*.xl*")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        Do While FileName <> ""
            Set WBK = Workbooks.Open(FolderPath & FileName)
            strWBName = Left(WBK.Name, (InStrRev(WBK.Name, ".", -1, vbTextCompare) - 1))

            For Each Cell In ThisWorkbook.Sheets("Sheet1").Range("A2:A6")
                If Cell.Value = strWBName And Cell.Offset(, 1) <> "" Then
                    With WBK.Sheets("المعلومات الأساسية")
                        Range("A6").Value = "تاريخ الاستقالة"
                        Range("B6").Value = Cell.Offset(, 1)
                        Range("B6").NumberFormat = "m/d/yyyy"
                    End With
                    Exit For
                End If
            Next Cell
            
            WBK.Close SaveChanges:=True
            FileName = Dir()
        Loop
        Range("A1").Select
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

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

لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي

تقبل تحياتي

Loop Through Closed Workbooks YK.rar

[أسامة البراوى]

 السلام عليكم

 

بعد إذن الاستاذ الكبير ياسر (علشان انا كنت باجهز الرد)

 

ممكن برضه تجرب الكود ده

Sub UpdateData()
    Dim R
    Dim WbkName As String
    Dim MyPath As String
    
    MyPath = ActiveWorkbook.Path
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    Dim xl0 As New Excel.Application
    
    For R = 2 To 6
    WbkName = MyPath & Cells(R, 1) & ".xlsx"
    Dim xlw As New Excel.Workbook
    Set xlw = xl0.Workbooks.Open(WbkName)
    
    xl0.Worksheets("المعلومات الأساسية").Cells(6, 1) ="تاريخ الاستقالة"
    xl0.Worksheets("المعلومات الأساسية").Cells(6, 2).Value = ActiveSheet.Cells(R, 2).Value
    xlw.Save
    xlw.Close
    Set xl0 = Nothing
    
    Next
    
    Set xlw = Nothing
End Sub

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

بسم الله ما شاء الله أخي أسامة

بارك الله فيك

 

ملحوزة صغيرة .. متنساش تلغي اهتزاز الشاشة وخلافه حتى يستغرق الكود وقت أقل ..

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

 

حاجة تانية

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

xl0.Worksheets("المعلومات الأساسية")

الأفضل نستخدم جملة

With xl0.Worksheets("المعلومات الأساسية")

End With

أنا مش بعدل عليك ..أنا بس بفكر بصوت عالي عشان نوصل لأفضل الحلول ..

يداً بيد نبني قلعة الأكواد الحصينة ( YK & OB) :fff:

[أسامة البراوى]

تمام يا استاذ ياسر بخصوص كود الاهتزاز

اما بخصوص ال with

فدى ممكن الاستغناء عنها لو كانت البيانات المنقولة قليلة

 

وان شاء الله ها نعمل قلعة الاكواد وانتظر منى حاجة بعد شوية

[أبو محمد المنار]

جزاكما الله خيرا على الاجابة

 

وبارك الله فيكم