Code To Look For Number On Sheet 1 And Put Another Number Directly Below

[Dazzawm]

I have sheet 2 with a list of numbers in column A. I need a code please that will look for these numbers on sheet 1 in column AD and put the number that is next to it in column B on sheet 2 in the cell directly below in column Ad on sheet 1. Thanks.

Excel 2010
	A	B
1
2	Test	Test1
3	Data	Data1
Sheet2

Sheet 1 Before

Excel 2010
	AD
2	Test
3	NYA
4	NYA
5	Test
6	NLA
7	Data
8	NYA
9	NYA
10	NYA
11	NYA
12	Data
Sheet1

Sheet 1 After. I have highlighted the cells where the data has been added.

Excel 2010
	AD
2	Test
3	Test1
4	NYA
5	Test
6	Test1
7	Data
8	Data1
9	NYA
10	NYA
11	NYA
12	Data
13	Data1
Sheet1

Thanks.

 

[Worf]

Please test this:

Sub MG13Oct00_Worf()
Dim Rng1 As Range, Dn As Range, Rng2 As Range
With Sheets("Sheet2")
    Set Rng2 = .Range(.[A1], .Range("A" & Rows.Count).End(xlUp))
End With
With Sheets("Sheet1")
    Set Rng1 = .Range(.[AD1], .Range("AD" & Rows.Count).End(xlUp))
End With
With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In Rng2
       Set .Item(Dn.Value) = Dn
    Next
    Sheets("sheet2").Activate
    For Each Dn In Rng1
        If .Exists(Dn.Value) Then
            If Dn.Offset(1) = "NLA" Or Dn.Offset(1) = "NYA" Or Dn.Offset(1) = "N/A" Then
                Dn.Offset(1) = .Item(Dn.Value).Offset(, 1)
                Dn.Offset(1, 1) = .Item(Dn.Value).Offset(, 2)
            Else
                Sheets("sheet3").Cells(Sheets("sheet3").Range("a" & _
                Rows.Count).End(xlUp).Row + 1, 1) = Dn.Offset(1)
            End If
        End If
    Next
End With
End Sub

 

[Dazzawm]

Thanks worf, it mainly worked. The only problem was sheet 3. It didn't list the cell reference where the data couldn't be put below because there was something other than NYA, NLA or N/A. It seemed that it listed what was below, rather than saying for example 'AD23 couldn't be changed because something else was there'.

 

[Dazzawm]

Also please worf I have just realised some files I will use this on may have data already on sheet 3. Could a sheet be created please called summary?

 

[Worf]

New version:

Function SheetExists(s$) As Boolean
Dim x As Object
SheetExists = False
On Error Resume Next
Set x = ActiveWorkbook.Sheets(s)
If Err.Number = 0 Then SheetExists = True
On Error GoTo 0
End Function


Sub MG13Oct00_Worf()
Dim Rng1 As Range, Dn As Range, Rng2 As Range, sm As Worksheet
With Sheets("Sheet2")
    Set Rng2 = .Range(.[a1], .Range("A" & Rows.count).End(xlUp))
End With
With Sheets("Sheet1")
    Set Rng1 = .Range(.[AD1], .Range("AD" & Rows.count).End(xlUp))
End With
If Not SheetExists("summary") Then
    Sheets.Add , Sheets(Sheets.count)
    Sheets(Sheets.count).Name = "Summary"
End If
Set sm = Sheets("summary")
sm.[a:a].ClearContents
sm.[a1] = "Addresses are listed below:"
With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In Rng2
       Set .Item(Dn.Value) = Dn
    Next
    Sheets("sheet2").Activate
    For Each Dn In Rng1
        If .Exists(Dn.Value) Then
            If Dn.Offset(1) = "NLA" Or Dn.Offset(1) = "NYA" Or Dn.Offset(1) = "N/A" Then
                Dn.Offset(1) = .Item(Dn.Value).Offset(, 1)
                Dn.Offset(1, 1) = .Item(Dn.Value).Offset(, 2)
            Else
                sm.Cells(sm.Range("a" & Rows.count).End(xlUp).Row + 1, 1) = Dn.Offset(1).Address
            End If
        End If
    Next
End With
End Sub

 

[Dazzawm]

Thanks worf, works perfect. Thanks for your time.

 

[Dazzawm]

Hi again worf. Sorry to put you to more trouble but as well as a summary sheet of cells that could not be changed, could each row be highlighted in a colour also please?

 

[Worf]

See if this highlights the correct data:

Sub MG13Oct00_Worf()
Dim Rng1 As Range, Dn As Range, Rng2 As Range, sm As Worksheet
With Sheets("Sheet2")
    Set Rng2 = .Range(.[a1], .Range("A" & Rows.Count).End(xlUp))
End With
With Sheets("Sheet1")
    Set Rng1 = .Range(.[AD1], .Range("AD" & Rows.Count).End(xlUp))
End With
If Not SheetExists("summary") Then
    Sheets.Add , Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Summary"
End If
Set sm = Sheets("summary")
sm.[a:a].ClearContents
sm.[a1] = "Addresses are listed below:"
With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For Each Dn In Rng2
       Set .Item(Dn.Value) = Dn
    Next
    Sheets("sheet2").Activate
    For Each Dn In Rng1
        If .Exists(Dn.Value) Then
            If Dn.Offset(1) = "NLA" Or Dn.Offset(1) = "NYA" Or Dn.Offset(1) = "N/A" Then
                Dn.Offset(1) = .Item(Dn.Value).Offset(, 1)
                Dn.Offset(1, 1) = .Item(Dn.Value).Offset(, 2)
            Else
                sm.Cells(sm.Range("a" & Rows.Count).End(xlUp).Row + 1, 1) = Dn.Offset(1).Address
                Dn.Offset(1).Interior.Color = RGB(160, 110, 150)
            End If
        End If
    Next
End With
End Sub

 

[Dazzawm]

Thanks worf it does appear to work, however could it highlight the entire row rather than just the cell please.

 

[Worf]

Use this instead:

Dn.Offset(1).EntireRow.Interior.Color = RGB(170, 120, 160)

 

[Dazzawm]

Thanks mate.