التعديل أو الحذف علي مجموعة ملفات في إيكسيل دفعة واحدة

[bando]

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

التعديل لي مجموعة ملفات في إيكسيل دفعة واحدة.zip

[حسونة حسين]

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

محتاج تمسح الارقام فقط ام السطر كاملا الذي به الرقم 

[bando]

هلا وغلا حياك أخوي
حذف الصف كامل حتى لا يكون هناك خلايا فارغة

 

[حسونة حسين]

تفضل اخى الكريم 

ضع هذا الكود في ملف ( الميكرو المستخدم في التعديل علي الملفات.xlsx) 

فى موديل عادى ثم شغل الكود 

Option Explicit
Sub Delete_Row_If_Equal_A_Specific_Value()
    Dim WB As Workbook, WS As Worksheet, SH As Worksheet, sPath As String, sFile As String
    Dim C As Range, M As Long, R As Long
    Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False
    Set SH = ThisWorkbook.Worksheets("Sheet1")
    sPath = ThisWorkbook.Path & "\الملفات\"
    sFile = Dir(sPath & "*.xls*")
    Do While sFile <> ""
        Set WB = Workbooks.Open(sPath & sFile, False)
        For Each WS In WB.Worksheets
            M = WS.Range("A" & Rows.Count).End(xlUp).Row
            For R = 2 To M
                Set C = WS.Range("A:A").Find(What:=SH.Range("A" & R).Value, LookAt:=xlWhole)
                If C Is Nothing Then GoTo 1
                WS.Rows(C.Row).Delete
1           Next R
        Next WS
        WB.Close SaveChanges:=True
        sFile = Dir
    Loop
    Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub

 

[bando]

للأسف لم تعمل

[حسونة حسين]

ماذا الذي لم يعمل اخى

[bando]

الكود لم يعمل فقط يعلق لفتره بدون ما يسوي أي تغير 

 

[حسونة حسين]

ارفق ملفك اخى بعد وضع الكود به 

[bando]

26 دقائق مضت, hassona229 said:

ارفق ملفك اخى بعد وضع الكود به 

تم إرفاق الملف

التعديل لي مجموعة ملفات في إيكسيل دفعة واحدة.rar

[ميدو63]

الكود يعمل على الملفات الموجودة فقط في ملف 222 ولا يعمل على الملف الخارجي الموجود به الكود

[حسونة حسين]

اخى عدل هذا السطر 

If C Is Nothing Then GoTo 1
ليكون 
If C Is Nothing Or IsEmpty(C) Then GoTo

وحاجه تانيه الملف الذي به الكود جميع الارقام التي به ليست موجوده في الملفات الموجوده في فولدر 222

في اخر ملف لك 

اما في الملف الاول لك في اول مشاركه الارقام موجوده ويحذفها 

[حسونة حسين]

هنا الكود كاملا 

Option Explicit
Sub Delete_Row_If_Equal_A_Specific_Value()
    Dim WB As Workbook, WS As Worksheet, SH As Worksheet, sPath As String, sFile As String
    Dim C As Range, M As Long, R As Long
    Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False
    Set SH = ThisWorkbook.Worksheets("Sheet1")
    sPath = ThisWorkbook.Path & "\222\"
    sFile = Dir(sPath & "*.xls*")
    Do While sFile <> ""
        Set WB = Workbooks.Open(sPath & sFile, False)
        For Each WS In WB.Worksheets
            M = SH.Range("A" & Rows.Count).End(xlUp).Row
            For R = 2 To M
                Set C = WS.Range("A:A").Find(What:=SH.Range("A" & R).Value, LookAt:=xlWhole)
                If C Is Nothing Or IsEmpty(C) Then GoTo 1
                WS.Rows(C.Row).Delete
1           Next R
        Next WS
        WB.Close SaveChanges:=True
        sFile = Dir
    Loop
    Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub

 

[bando]

منذ ساعه, hassona229 said:

هنا الكود كاملا 

Option Explicit
Sub Delete_Row_If_Equal_A_Specific_Value()
    Dim WB As Workbook, WS As Worksheet, SH As Worksheet, sPath As String, sFile As String
    Dim C As Range, M As Long, R As Long
    Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False
    Set SH = ThisWorkbook.Worksheets("Sheet1")
    sPath = ThisWorkbook.Path & "\222\"
    sFile = Dir(sPath & "*.xls*")
    Do While sFile <> ""
        Set WB = Workbooks.Open(sPath & sFile, False)
        For Each WS In WB.Worksheets
            M = SH.Range("A" & Rows.Count).End(xlUp).Row
            For R = 2 To M
                Set C = WS.Range("A:A").Find(What:=SH.Range("A" & R).Value, LookAt:=xlWhole)
                If C Is Nothing Or IsEmpty(C) Then GoTo 1
                WS.Rows(C.Row).Delete
1           Next R
        Next WS
        WB.Close SaveChanges:=True
        sFile = Dir
    Loop
    Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub

 

ما شاء الله عليك أخي @hassona229 
والله إنك كفووو جزاك الله كل خير ونفع الله بك المسلمين 
تسلم يالأمير 🤩

[حسونة حسين]

وجزاكم مثله اخى الكريم على دعاؤك الطيب

الحمد لله الذي بنعمته تتم الصالحات