تعديل فى كود ترحيل لملف اخر يمكنى من الغاء قيد

[طارق_طلعت]

 

السادة الزملاء الأعزاء

بعد التحية

الكود المرفق هو كود للعلامة القدير الأستاذ ياسر ابو البراء و هو يقوم بترحيل البيانات من ملف الى ملف اخر بنفس الفولدر و الكود ممتاز و يعمل بشكل جيد منذ خمس سنوات

و فى بعض الأحيان يتم اكتشاف خطأ فى قيد قديم و يتطلب الأمر الغاء القيد

و المطلوب ان يتم عمل كود اخر يقوم بألغاء القيد من الشيتات التى تم القيد بها و ذلك بمعلومية رقم القيد و اظهار النتيجة طبقا للملف المرفق (النتيجة المطلوبة) 
كما مرفق فولدر به الملفين الأصليين و ملف اخر بة النتيجة المطلوبة 

و شكرا لحسن تعاونكم

Sub TransferDataToClosedWB()
    Dim WB As Workbook, SH As Worksheet
    Dim Cell As Range
    Dim strWB As String
    Dim LR_A As Long, LR_B As Long

    LR_A = IIf(Cells(Rows.Count, 1).End(xlUp).Row < 13, 13, Cells(Rows.Count, 1).End(xlUp).Row)
    strWB = ThisWorkbook.Path & "\" & "حسابات تجهيز.xlsm"
    
    Application.ScreenUpdating = False
        If Application.WorksheetFunction.CountA(Range("A13:A" & LR_A)) < 1 Then MsgBox "لا يوجد بيانات لترحيلها", vbInformation: Exit Sub
        
        On Error Resume Next
        
        If FileInUse(strWB) Then
            Set WB = Workbooks("حسابات تجهيز.xlsm")
        Else
            Set WB = Workbooks.Open(Filename:=strWB)
        End If
        
        For Each Cell In ThisWorkbook.Sheets("ترحيل").Range("A13:A" & LR_A)
            For Each SH In WB.Sheets
                If SH.Name = Cell.Value Then
                    With SH
                        LR_B = IIf(.Cells(Rows.Count, 4).End(xlUp).Row < 16, 16, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                        Cell.Offset(, 2).Resize(, 5).Copy
                        .Range("A" & LR_B).PasteSpecial xlPasteValues
                    End With
                End If
            Next SH
        Next Cell
    WB.Sheets(1).Activate
    ThisWorkbook.Activate
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Public Function FileInUse(sFileName) As Boolean
    On Error Resume Next
    Open sFileName For Binary Access Read Lock Read As #1
    Close #1
    FileInUse = IIf(Err.Number > 0, True, False)
    On Error GoTo 0
End Function

 

test 2.zip

[طارق_طلعت]

ارجوا من الساده الافاضل المساعده