problem delete unmatched items using dictionary and array(shouldn't)

[abdelfattah]

Hi
I have problem in this code . it deletes items from sheet ITEMS because of they are not existed in sheet1
I want keeping new items in sheet ITEMS even if they are not existed in sheet1
the code should match column B between two sheets and pull the values from columns C,D from sheet1 to sheet ITEMS and if there is new item in sheet1 but is not existed in sheet ITEMS , then should add to sheet items. the only problem as I said before , it deletes items from sheet ITEMS because of they are not existed in sheet1 , shouldn't !
I hope finding assistance from experts.

Sub test1()
    Dim ws As Worksheet, a, i As Long, w, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set ws = Sheets("SHEET1")
    With ws
            a = ws.Cells(1).CurrentRegion.Value
            For i = 2 To UBound(a, 1)
                If a(i, 2) <> "" Then
                    If Not dic.exists(a(i, 2)) Then
                        ReDim w(1 To 4)
                        w(2) = a(i, 2)
                    Else
                        w = dic(a(i, 2))
                    End If
                    w(3) = a(i, 3): w(4) = a(i, 4)
                    dic(a(i, 2)) = w
                   
                End If
            Next
    End With
    With Sheets("ITEMS").Cells(1).CurrentRegion
        .Offset(1).ClearContents
        If dic.Count Then
            With .Rows(2).Resize(dic.Count)
                .Value = Application.Index(dic.items, 0, 0)
                .Columns(1) = Evaluate("row(1:" & .Rows.Count & ")")
            End With
        End If
    End With
End Sub

 

[Alex Blakenburg]

Give this a try.

    Dim ws1 As Worksheet, rng1 As Range, arr1 As Variant, lr1 As Long, i As Long, w, dic1 As Object
    Dim wsItems As Worksheet, rngItems As Range, arrItems As Variant
    
    Set ws1 = Sheets("SHEET1")
    lr1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
    Set rng1 = ws1.Cells(1).CurrentRegion
    arr1 = rng1.Value
    
    Set wsItems = Sheets("ITEMS")
    Set rngItems = wsItems.Cells(1).CurrentRegion
    arrItems = rngItems.Value
    
    ' Load Sheet1 into dictionary
    Set dic1 = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(arr1, 1)
        If Not dic1.exists(arr1(i, 2)) Then
            dic1(arr1(i, 2)) = i
        End If
    Next i

    ' For Items sheet get Column C & D for matching items
    For i = 2 To UBound(arrItems, 1)
            If dic1.exists(arrItems(i, 2)) Then
                arrItems(i, 3) = arr1(dic1(arrItems(i, 2)), 3)
                arrItems(i, 4) = arr1(dic1(arrItems(i, 2)), 4)
            Else
                ' Write missing from Sheet1
                lr1 = lr1 + 1
                ws1.Range("B" & lr1) = arrItems(i, 2)
            End If
    Next i
    
    ' Write Items Columns C & D
    rngItems.Columns(3).Value = Application.Index(arrItems, 0, 3)
    rngItems.Columns(4).Value = Application.Index(arrItems, 0, 4)

End Sub

 

[abdelfattah]

Hi Alex

thanks for reproduce the code . there are some problems

your code doesn't brings new items from sheet1 to sheet ITEMS this is what code does it . your code does reversation ( brings new values from sheet ITEMS to sheet1 , I don't want it ) .

my requirements should pull values for colums C,D based on matching column B from sheet1 to sheet items and if there is new items in sheet ITEMS and there is not existed in sheet1 ,then should keep in sheet ITEMS without add to sheet1( my problem is if there is new items in sheet ITEMS and there is not existed in sheet1 will delete from sheet ITEMS ) , and if there is new items in sheet1 and is not existed in sheet ITEMS , then should add to sheet ITEM and this is what code works as in OP .

I hope this details help you to understand me what I want.

 

[Alex Blakenburg]

You are right I was unclear on what you wanted but since we are in very different time zones it was easier to give you some code to start with than to ask questions.
I will modify the code but it won't be until this time tomorrow.

 

[Alex Blakenburg]

Oh and if missing from Items, do you just want columns B,C & D from Sheet1 to be added to Items ?

 

[abdelfattah]

I will modify the code but it won't be until this time tomorrow.

this is not problem . take your time

Oh and if missing from Items, do you just want columns B,C & D from Sheet1 to be added to Items ?

surely with considering numbers sequences in column A when added .

 

[Alex Blakenburg]

Give this a try:

Sub test1_Compare_alternate()
    Dim ws1 As Worksheet, rng1 As Range, arr1 As Variant, lr1 As Long, i As Long
    Dim wsItems As Worksheet, rngItems As Range, arrItems As Variant, lrItems As Long, dicItems As Object
    
    Set ws1 = Sheets("SHEET1")
    lr1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
    Set rng1 = ws1.Cells(1).CurrentRegion
    arr1 = rng1.Value
    
    Set wsItems = Sheets("ITEMS")
    lrItems = wsItems.Range("B" & Rows.Count).End(xlUp).Row
    Set rngItems = wsItems.Cells(1).CurrentRegion
    arrItems = rngItems.Value
    
    ' Load Items sheet into dictionary
    Set dicItems = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(arrItems, 1)
        If Not dicItems.exists(arrItems(i, 2)) Then
            dicItems(arrItems(i, 2)) = i
        End If
    Next i

    ' For Items sheet get Column C & D for matching items
    colMissing = UBound(arr1, 2) + 1
    ReDim Preserve arr1(1 To UBound(arr1), 1 To colMissing)
    For i = 2 To UBound(arr1, 1)
            If dicItems.exists(arr1(i, 2)) Then
                arrItems(dicItems(arr1(i, 2)), 3) = arr1(i, 3)
                arrItems(dicItems(arr1(i, 2)), 4) = arr1(i, 4)
            Else
                ' Write missing from Items
                ' If you have a lot missing we should convert this to an array
                lrItems = lrItems + 1
                wsItems.Range("B" & lrItems) = arr1(i, 2)
                wsItems.Range("C" & lrItems) = arr1(i, 3)
                wsItems.Range("D" & lrItems) = arr1(i, 4)
            End If
    Next i
    
'    ' Write Items Columns C & D
    rngItems.Columns(3).Value = Application.Index(arrItems, 0, 3)
    rngItems.Columns(4).Value = Application.Index(arrItems, 0, 4)
    
    With wsItems.Rows(2).Resize(lrItems - 1)
        .Columns(1) = Evaluate("row(1:" & .Rows.Count & ")")
    End With

End Sub

 

[abdelfattah]

wow ! your code is really fast . I don't fell your code works , I thought the code doesn't work .
it's really excellent !
many thanks for your assistance .

 

[Alex Blakenburg]

You’re welcome. Glad I could help.