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

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
85
Office Version
  1. 365
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

VBA Code:
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?
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
67,955
Office Version
  1. 365
Platform
  1. Windows
Are the values on both sheets unique, or could they occur multiple times?
 

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
85
Office Version
  1. 365
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

1635434747179.png
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
67,955
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
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
 
Solution

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,761
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

According to the visual example without any header a VBA demonstration for starters :​
VBA Code:
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

Board Regular
Joined
Nov 12, 2019
Messages
85
Office Version
  1. 365
Ok, how about
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
67,955
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,856
Messages
5,766,784
Members
425,378
Latest member
kapoor2892

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top