تعديل كود بحث عن البيانات في ملفات مغلقه

[yasse.w.2010]

كود يبحث داخل الملفات وهي مغلقة معدل.rar

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

الاساتذه الكرام

ارجو من سيادتكم التعديل على الكود الموجود في ملف داتا

بحيث يعمل لصق للبيانات بصيغة Paste:=xlPasteValues  لصق بدون تنسيق الخلايا

شاكر لكم جدا

مع العلم بان الملف يعمل ولاكن ( بيعمل لصق للبيانات بتنسيق الخلايا وايضا بالمعادلات - و المعادلات مرتبطه بملفات اخري )

الكود موجود في مديول ميكرو رقم 1 في شيت داتا

 

ممكن حضرتك تعدلي في الكود ده بحيص يجلب البيانات من الشيتات المغلقه التي اسمها reservation بحيث الملفات بها اوراق عمل كثيره 

لا يجلب البيانات الا من ورقت العمل التي اسمها reservation 

DATA.xlsm

[حسونة حسين]

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

تفضل اخي ياسر @yasse.w.2010 تعديل بسيط على كودك

وتم اضافه شرط ان لم يكن يوجد صفحه بالاسم الذي تريد ان لا يعطى خطأ ويفتح الملف التالي

Sub information()

    Dim wb As Workbook, WS As Worksheet, lr1 As Integer, lr2 As Integer
    Dim fil As Variant, dat As Long
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Temp")
    Application.ScreenUpdating = False  ''' غلق اهتزاز الشاشه
    Application.DisplayAlerts = False   ''' غلق اي رساله تظهر مثل الحفظ الخ

    lr1 = sh.Cells(Rows.Count, 1).End(xlUp).Row    ''' ار صف فيه بيانات في العامود الاول
    sh.Range("A10:k" & lr1 + 1).ClearContents    '''مسح البيانات في هذا النطاق

    INF = ThisWorkbook.Path  '''مسار الملف
    fil = Dir(INF & "\*.xl??")    ''' مسار الملف في اي مكان

    Do While fil <> ""    ''' المرور على كل الملفات
        If fil <> "DATA.xlsm" Then    ''' اسم الملف الذي لا يتم جلب البيانات منه
            Set wb = Workbooks.Open(INF & "\" & fil)    ''' فتح الملففات من المسار
            lr1 = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1    ''' تحديد مكان نسخ الخلايا
            If Not IsError(Evaluate("ISREF('[" & wb.Name & "]" & "reservation" & "'!A1)")) Then
                Set WS = wb.Worksheets("reservation")
                lr2 = WS.Cells(Rows.Count, 2).End(xlUp).Row    ''' تحديد عامود اخر خليه بها بيانات ليتم نسخها
                WS.Range("A8:k" & lr2).Copy                      '''نسخ البيانات من الملف الى ملف اخر
                sh.Range("a" & lr1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                dep = Left(wb.Name, Application.Search(".", wb.Name) - 1)    ''' تحديد اسم اسم الملف و الغاء الامتداد الخاص بالملف
                sh.Range("h" & lr1 & ":h" & lr1 + lr2 - 8) = dep  ''' مكان اسم الملف
            End If
            wb.Close    ''' غلق الملف
        End If
        fil = Dir    ''' تكرار الملفات
    Loop

    Application.DisplayAlerts = True  ''' فتج اهتزاز الشاشه
    Application.ScreenUpdating = True    ''' فنح رسائل الحفظ

End Sub

[حسونة حسين]

قم بحذف جميع السطور من بدايه السطر ١٠ الي نهايه الشيت

لان بها خلايا مدمجه

مثل الصورة

[yasse.w.2010]

الف شكر لحضرتك

عملت ال حضرتك قولته والملف اشتغل

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

الف شكر منتدى اوفسينا

[حسونة حسين]

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