تعديل كود الاحتياطي Compare2

[بلانك]

 الكود  Compare2 ......... المطلوب  تعديلة فهو مقتبس من احد الملفات للامانة

الاحتياطي.rar

[عبدالله بشير عبدالله]

السلام عليكم

حسب قهمي للكود

الكود يتعامل مع العمود A والذي به ترقيم

والمفترض التعامل مع الاسماء في العمود B

اذا كان فهمي للامر صحيح اليك الكود المعدل والا قم بتوضيح الامر اكثر

تصوري Sub Compare2()
    Dim lr As Long, i As Long, j As Long
    Dim strCol As String
    Dim WS As Worksheet: Set WS = Worksheets("Data")
    Dim hasMissing As Boolean: hasMissing = False
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    lr = WS.Columns("B").Find(What:="*", SearchDirection:=xlPrevious).Row
    On Error GoTo 0
    
    If lr < 6 Then
        Application.ScreenUpdating = True
        Exit Sub
    End If

    For i = 6 To 18
        strCol = Split((WS.Columns(i).Address(, 0)), ":")(0)
        
        Dim lastInCol As Long
        lastInCol = WS.Cells(WS.Rows.Count, strCol).End(xlUp).Row
        If lastInCol < 6 Then lastInCol = 6

        For j = 6 To lr
            If WorksheetFunction.CountIf(WS.Range(strCol & "6:" & strCol & lastInCol + 500), WS.Range("B" & j)) = 0 Then
                With WS.Cells(WS.Rows.Count, strCol).End(xlUp).Offset(1)
                    .Value = WS.Range("B" & j).Value
                End With
                
                hasMissing = True
                lastInCol = lastInCol + 1
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = True

End Sub

  

 

تم تعديل منذ 1 ساعه بواسطه عبدالله بشير عبدالله

[بلانك]

تمام بارك الله فيك وجعله في ميزان حسناتك