Comparing lists of values, & adding unique values to the 1st blank cells of a range

[jamesg]

Hi All,

I have 2 sheets with columns of numbers (A1:A500). I would like a macro that compares the 2 sets of numbers and adds any number unique to Sheet 1-Column A (ie. not in Sheet 2-Column A) to the 1st blank cell of Column A (on Sheet 2). I don't want a simple copy paste as the Sheet 2 list is sorted with adjacent values that need to stay unscrambled.

Any help is greatly appreciated.

James

[westconn1]

try like

lastrw = Sheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Row
For Each cel In Sheets("sheet1").Range("a1:a500")
Set fnd = Sheets("sheet2").Range("a1:A" & lastrw).Find(cel)
If fnd Is Nothing Then Sheets("sheet2").Range("a" & lastrw + 1).Value = cel
lastrw = lastrw + 1
Nextchange sheet names to suit
declare all variables etc

[sassora]

Hi James

Is this the sort of thing you are after?


Option Explicit


Sub AddMissedValuesFromList()
Dim cellrange As Range
Dim lastrowSh2 As Long


lastrowSh2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row


For Each cellrange In Sheets("Sheet1").Range("A1:A500").SpecialCells(2)
If IsError(Application.Match(cellrange, Sheets("Sheet2").Range("A1:A500"), 0)) Then
lastrowSh2 = lastrowSh2 + 1
Sheets("Sheet2").Range("A" & lastrowSh2) = cellrange.Value
End If
Next cellrange


End Sub

[stanleydgrom]

jamesg,

The following works in my test environment.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).




Option Explicit
Sub AddUniquesToW2()
' stanleydgrom, 12/24/2013
' http://www.vbaexpress.com/forum/showthread.php?48521-Comparing-lists-of-values-amp-adding-unique-values-to-the-1st-blank-cells-of-a-range
Dim c As Range, frng As Range, lr As Long
lr = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("Sheet1")
For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
If c <> "" Then
Set frng = Sheets("Sheet2").Columns(1).Find(c.Value)
If frng Is Nothing Then
lr = lr + 1
Sheets("Sheet2").Cells(lr, 1) = c.Value
End If
End If
Next c
End With
End Sub



Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the AddUniquesToW2 macro.

[jamesg]

Hi James

Is this the sort of thing you are after?


Option Explicit


Sub AddMissedValuesFromList()
Dim cellrange As Range
Dim lastrowSh2 As Long


lastrowSh2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row


For Each cellrange In Sheets("Sheet1").Range("A1:A500").SpecialCells(2)
If IsError(Application.Match(cellrange, Sheets("Sheet2").Range("A1:A500"), 0)) Then
lastrowSh2 = lastrowSh2 + 1
Sheets("Sheet2").Range("A" & lastrowSh2) = cellrange.Value
End If
Next cellrange


End Sub



Hi Sassora,

This really great, almost perfect.

I should have mentioned in the original request that Sheet1-Column A5:A2005 values are index numbers so the whole column is populated 1 thru 2000, therefore this macro takes across all values including the heading in A4. Could you suggest and amendment that only takes the value unique to sheet1 across to sheet2 if the adjacent cell in Column C has the words "List" or "Pour" in it, or is not blank.

EG If number in A is not on sheet2 and the adjacent cell of column C is not blank, take it across and add it to the bottom of the list on sheet2.

Any help is greatly appreciated.
James

[sassora]

Hi James - didn't notice your reply until now.

Amend the if statement below as relevant, currently only moves figures across if column C is not blank (and only looks a numbers in row 5 and above).

Sub AddMissedValuesFromList()

Dim lastrowSh2 As Long
lastrowSh2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row

Dim cel As Range
For Each cel In Sheets("Sheet1").Columns(1).SpecialCells(2)
If cel.Offset(, 2) <> "" and cel.row > 4 Then
If Sheets("Sheet2").Columns(1).Find(cel.Value) Is Nothing Then
lastrowSh2 = lastrowSh2 + 1
Sheets("Sheet2").Range("A" & lastrowSh2) = cel.Value
End If
End If
Next cel

End Sub