If value from range in Sheet1, is not in Sheet2, add to range in Sheet2.

[noslenwerd]

I think I am close with my code below, but it doesn't function quite as flawlessly.

What I am trying to achieve is:

• Check to see if cell in Sheet1 range (found in column A), exists in Sheet2 column A.
  • If cell exists in Sheet2, +1 to the value in column B
  • If cell DOES NOT exist in Sheet2, copy that cell to the end of Sheet2 columnA, and +1 to the value in columnB

Sub UpdateCount()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range

Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'find last row
    Set rng = sh1.Range("A2:A" & lr) 'set range to all non-blank cells in Sheet1 Column A
        For Each c In rng 'Run through each cell in rng
            If WorksheetFunction.CountIf(sh2.Range("A:A"), c.Value) = WorksheetFunction.CountIf(sh1.Range("A:A"), c.Value) Then 'If cell in Sheet1, matches a value in Sheet2, add 1 to value in Column B
                sh2.Range("A" & (c.Row)).Offset(, 1).Value = sh2.Range("A" & (c.Row)).Offset(, 1).Value + 1 'This is where I believe something is wrong with the code
            End If
            If WorksheetFunction.CountIf(sh2.Range("A:A"), c.Value) = 0 Then 'If cell from Sheet1, is not in Sheet2, copy to Sheet2, and add +1 to column B
                sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)(2) = c.Value
                sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row).Offset(, 1).Value = sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row).Offset(, 1).Value + 1
            End If
        Next
        
End Sub

The issue is, it does add the missing values to Sheet2, but at times it doesn't add +1 to column B correctly.

Any ideas?

 

[Fluff]

Are the values on both sheets unique, or could they occur multiple times?

 

[noslenwerd]

Are the values on both sheets unique, or could they occur multiple times?

Correct.. So you will never see sheet 1 with:
Apple
Apple
Pear
Banana
Banana

They will always be unique.

Here is a visual example of what I am trying to achieve

 

[Fluff]

Ok, how about

Sub noslenwerd()
   Dim Cl As Range
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets(1)
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Value) = Empty
      Next Cl
   End With
   With Sheets(2)
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic.Exists(Cl.Value) Then
            Cl.Offset(, 1).Value = Cl.Offset(, 1).Value + 1
            Dic.Remove Cl.Value
         End If
      Next Cl
      If Dic.Count > 0 Then
         With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count)
            .Value = Application.Transpose(Dic.Keys)
            .Offset(, 1).Value = 1
         End With
      End If
   End With
End Sub

 

[Marc L]

According to the visual example without any header a VBA demonstration for starters :​

Sub Demo1()
        Dim V, W
        Application.ScreenUpdating = False
    For Each V In Sheets(1).UsedRange.Columns(1).Value2
        With Sheets(2).[A1].CurrentRegion
            W = Application.Match(V, .Columns(1), 0)
            If IsError(W) Then .Rows(.Rows.Count - Not IsEmpty(.Cells(1))).Range("A1:B1").Value2 = Array(V, 1) _
                          Else With .Cells(W, 2): .Value2 = .Value2 + 1: End With
        End With
    Next
        Application.ScreenUpdating = True
End Sub

 

[noslenwerd]

Ok, how about

Sub noslenwerd()
   Dim Cl As Range
   Dim Dic As Object
  
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets(1)
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         Dic(Cl.Value) = Empty
      Next Cl
   End With
   With Sheets(2)
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Dic.Exists(Cl.Value) Then
            Cl.Offset(, 1).Value = Cl.Offset(, 1).Value + 1
            Dic.Remove Cl.Value
         End If
      Next Cl
      If Dic.Count > 0 Then
         With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count)
            .Value = Application.Transpose(Dic.Keys)
            .Offset(, 1).Value = 1
         End With
      End If
   End With
End Sub

Brilliant! This worked perfectly.

Thank you.

 

[Fluff]

You're welcome & thanks for the feedback.