Look at the name and give data out of another column!

Try this in the Worksheet code (right click on the sheet tab and choose "View Code")

You will need to amend the name of the sheet (if you are not using "Sheet1")

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Worksheets("Sheet1")
If Not Application.Intersect(Target, .[D4]) Is Nothing Then
Dim n As Integer
n = 0
Set c = .Columns(1).Find(.[D4], LookIn:=xlValues)
If Not c Is Nothing Then
firstc = c.Address
Do
c.Offset(0, 1).Copy Destination:=.[D6].Offset(n, 0)
n = n + 1
Set c = .Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstc
Else
.Range(Cells(6, 4), Cells(6, 4).End(xlDown)).Clear
End If
End If
End With
End Sub

Any help?

Regards

Sorry, but I realized I put the clear statement in the wrong place. This should work better:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Worksheets("Sheet1")
If Not Application.Intersect(Target, .[D4]) Is Nothing Then
.Range(Cells(6, 4), Cells(6, 4).End(xlDown)).Clear
Dim n As Integer
n = 0
Set c = .Columns(1).Find(.[D4], LookIn:=xlValues)
If Not c Is Nothing Then
firstc = c.Address
Do
c.Offset(0, 1).Copy Destination:=.[D6].Offset(n, 0)
n = n + 1
Set c = .Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstc
End If
End If
End With
End Sub

Regards

: If I have all kind of names in Column A and in Column B I've got all other data like Dates that people work. It's possible that in Column A a name is more then once in it! But with other data in Column B. And it's possible that the same name is for example in cells A4, A9, A233, etc. It can be really far away from each other. Now my question is if someone knows how I can let it search on a name which I fill in in cell D4 and that all the data of Column B that matches with that name appears in D6,D7,etc. till there's no more data for that name. I hope someone can help me with this?

Thanks it works!
But I actually want it to look up other cells! I want it to search the value from "sheet2" cell "D4" and I want it to show the columns 2,3,4,5 cause there's also info in those columns about that customer! Can you help me out with this one? And I want column 2 to be shown in cell "F1", column 3 in cell "H1", column 4 in cell "F3", column 5 in cell "I5"!

Thanks Sorry, but I realized I put the clear statement in the wrong place. This should work better: .Range(Cells(6, 4), Cells(6, 4).End(xlDown)).Clear Regards : With Worksheets("Sheet1") : If Not Application.Intersect(Target, .[D4]) Is Nothing Then : Dim n As Integer : n = 0 : Set c = .Columns(1).Find(.[D4], LookIn:=xlValues) : If Not c Is Nothing Then : firstc = c.Address : Do : c.Offset(0, 1).Copy Destination:=.[D6].Offset(n, 0) : n = n + 1 : Set c = .Columns(1).FindNext(c) : Loop While Not c Is Nothing And c.Address <> firstc : Else : .Range(Cells(6, 4), Cells(6, 4).End(xlDown)).Clear : End If : End If : End With : End Sub : : Any help? : Regards :

OK, but before I have a look at that, just a couple of points to clarify:

-By Columns 2,3,4,5 do you mean Columns C,D,E,F
I ask this because you previously wanted Column B (Column2) in D6, D7 etc
-Will all the values in Columns C,D,E,F be the samefor each entry for the customer?
I ask this because you only want those values in 1 cell each (it may also be impossible to
list values because you have a value in F1 (Column2) and F3 (Column4)

If you will clarify these points, I'll look at amending the code.

Regards

Ok, let me tell you what I want! I tried to ask you something and I thought I could figure out the cells like I've got it cause I've got a lot of them! Here's the way I have it and want it:
Column1 is the one I'm searching on and that's the one that's more than once in it but I want to be shown only once!

Sheet1: to Sheet2:
Column - Cell
1 - A2
2 - E2
3 - A5
4 - A8
5 - E8
6 - G8

I hope you can help me with this? Thanks!

OK, but before I have a look at that, just a couple of points to clarify: -By Columns 2,3,4,5 do you mean Columns C,D,E,F I ask this because you previously wanted Column B (Column2) in D6, D7 etc -Will all the values in Columns C,D,E,F be the samefor each entry for the customer? I ask this because you only want those values in 1 cell each (it may also be impossible to list values because you have a value in F1 (Column2) and F3 (Column4) If you will clarify these points, I'll look at amending the code. Regards

Try this.

It is set to search for the name you enter in D4 on Sheet2 - you may of course amend that if
you want to enter it somewhere else.

I have also set it to list mutliple values found in each of the columns other than A, since that is what you
originally indicated. You will need to make sure there are no more than 3 entries in some of the columns for a name,
or other data may be overwritten.

If you have any problems, post another follow-up to this message.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Application.EnableEvents = False
With sh2
If Not Application.Intersect(Target, .[D4]) Is Nothing Then
.Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear
.Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear
.Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear
.Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear
.Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear
.Cells(2, 1).Clear
Dim Cust
Cust = .[D4]
Else
GoTo NoFind
End If
End With
With sh1
Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer
n = 0
o = 0
p = 0
q = 0
r = 0
Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not c Is Nothing Then
firstc = c.Address
c.Copy Destination:=sh2.[A2]
Do
If c.Offset(0, 1) <> "" Then
c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0)
n = n + 1
Else
End If
If c.Offset(0, 2) <> "" Then
c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0)
o = o + 1
Else
End If
If c.Offset(0, 3) <> "" Then
c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0)
p = p + 1
Else
End If
If c.Offset(0, 4) <> "" Then
c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0)
q = q + 1
Else
End If
If c.Offset(0, 5) <> "" Then
c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0)
r = r + 1
Else
End If
Set c = .Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstc
End If
Set sh1 = Nothing
Set sh2 = Nothing
Application.EnableEvents = True
Exit Sub
End With
NoFind:
With sh2
.Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear
.Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear
.Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear
.Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear
.Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear
.Cells(2, 1).Clear
End With
Application.EnableEvents = True
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

Any help?

Regards

Ok, let me tell you what I want! I tried to ask you something and I thought I could figure out the cells like I've got it cause I've got a lot of them! Here's the way I have it and want it: Column1 is the one I'm searching on and that's the one that's more than once in it but I want to be shown only once! Sheet1: to Sheet2: Column - Cell 1 - A2 2 - E2 3 - A5 4 - A8 5 - E8 6 - G8 I hope you can help me with this? Thanks! : OK, but before I have a look at that, just a couple of points to clarify

Thinking about it, it makes no sense to clear the sheet if you enter something somewhere
other than D4 - this corrects that. By the way, the search is case sensitive.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Application.EnableEvents = False
With sh2
If Not Application.Intersect(Target, .[D4]) Is Nothing Then
.Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear
.Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear
.Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear
.Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear
.Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear
.Cells(2, 1).Clear
Dim Cust
Cust = .[D4]
Else
GoTo NoFind
End If
End With
With sh1
Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer
n = 0
o = 0
p = 0
q = 0
r = 0
Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not c Is Nothing Then
firstc = c.Address
c.Copy Destination:=sh2.[A2]
Do
If c.Offset(0, 1) <> "" Then
c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0)
n = n + 1
Else
End If
If c.Offset(0, 2) <> "" Then
c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0)
o = o + 1
Else
End If
If c.Offset(0, 3) <> "" Then
c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0)
p = p + 1
Else
End If
If c.Offset(0, 4) <> "" Then
c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0)
q = q + 1
Else
End If
If c.Offset(0, 5) <> "" Then
c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0)
r = r + 1
Else
End If
Set c = .Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstc
End If
End With
NoFind:
Application.EnableEvents = True
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

Regards

Try this. It is set to search for the name you enter in D4 on Sheet2 - you may of course amend that if you want to enter it somewhere else. I have also set it to list mutliple values found in each of the columns other than A, since that is what you originally indicated. You will need to make sure there are no more than 3 entries in some of the columns for a name, or other data may be overwritten. If you have any problems, post another follow-up to this message. Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet2") Application.EnableEvents = False With sh2 If Not Application.Intersect(Target, .[D4]) Is Nothing Then .Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear .Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear .Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear .Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear .Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear .Cells(2, 1).Clear Dim Cust Cust = .[D4] Else GoTo NoFind End If End With With sh1 Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer n = 0 o = 0 p = 0 q = 0 r = 0 Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True) firstc = c.Address c.Copy Destination:=sh2.[A2] Do If c.Offset(0, 1) <> "" Then c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0) Else End If If c.Offset(0, 2) <> "" Then c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0) o = o + 1 Else End If If c.Offset(0, 3) <> "" Then c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0) p = p + 1 Else End If If c.Offset(0, 4) <> "" Then c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0) q = q + 1 Else End If If c.Offset(0, 5) <> "" Then c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0) r = r + 1 Else End If Set c = .Columns(1).FindNext(c) Loop While Not c Is Nothing And c.Address <> firstc Set sh1 = Nothing Set sh2 = Nothing Application.EnableEvents = True Exit Sub NoFind: With sh2 .Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear .Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear .Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear .Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear .Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear .Cells(2, 1).Clear End With Application.EnableEvents = True Set sh1 = Nothing Set sh2 = Nothing Any help? Regards : Ok, let me tell you what I want! I tried to ask you something and I thought I could figure out the cells like I've got it cause I've got a lot of them! Here's the way I have it and want it

Thanks again, but the way I wanted it was that the target cells are on sheet 1 and the search stays on sheet 2. Hope you can help me?
Thanks Thinking about it, it makes no sense to clear the sheet if you enter something somewhere other than D4 - this corrects that. By the way, the search is case sensitive. Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet2") Application.EnableEvents = False With sh2 If Not Application.Intersect(Target, .[D4]) Is Nothing Then .Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear .Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear .Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear .Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear .Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear .Cells(2, 1).Clear Dim Cust Cust = .[D4] Else GoTo NoFind End If End With With sh1 Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer n = 0 o = 0 p = 0 q = 0 r = 0 Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True) firstc = c.Address c.Copy Destination:=sh2.[A2] Do If c.Offset(0, 1) <> "" Then c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0) Else End If If c.Offset(0, 2) <> "" Then c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0) o = o + 1 Else End If If c.Offset(0, 3) <> "" Then c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0) p = p + 1 Else End If If c.Offset(0, 4) <> "" Then c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0) q = q + 1 Else End If If c.Offset(0, 5) <> "" Then c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0) r = r + 1 Else End If Set c = .Columns(1).FindNext(c) Loop While Not c Is Nothing And c.Address <> firstc NoFind: Application.EnableEvents = True Set sh1 = Nothing Set sh2 = Nothing Regards

: Try this. : It is set to search for the name you enter in D4 on Sheet2 - you may of course amend that if : you want to enter it somewhere else. : I have also set it to list mutliple values found in each of the columns other than A, since that is what you : originally indicated. You will need to make sure there are no more than 3 entries in some of the columns for a name, : or other data may be overwritten. : If you have any problems, post another follow-up to this message. : Private Sub Worksheet_Change(ByVal Target As Excel.Range) : Dim sh1 As Worksheet, sh2 As Worksheet : Set sh1 = Worksheets("Sheet1") : Set sh2 = Worksheets("Sheet2") : Application.EnableEvents = False : With sh2 : If Not Application.Intersect(Target, .[D4]) Is Nothing Then : .Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear : .Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear : .Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear : .Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear : .Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear : .Cells(2, 1).Clear : Dim Cust : Cust = .[D4] : Else : GoTo NoFind : End If : End With : With sh1 : Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer : n = 0 : o = 0 : p = 0 : q = 0 : r = 0 : Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True) : If Not c Is Nothing Then : firstc = c.Address : c.Copy Destination:=sh2.[A2] : Do : If c.Offset(0, 1) <> "" Then : c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0) : n = n + 1 : Else : End If : If c.Offset(0, 2) <> "" Then : c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0) : o = o + 1 : Else : End If : If c.Offset(0, 3) <> "" Then : c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0) : p = p + 1 : Else : End If : If c.Offset(0, 4) <> "" Then : c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0) : q = q + 1 : Else : End If : If c.Offset(0, 5) <> "" Then : c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0) : r = r + 1 : Else : End If : Set c = .Columns(1).FindNext(c) : Loop While Not c Is Nothing And c.Address <> firstc : End If : Set sh1 = Nothing : Set sh2 = Nothing : Application.EnableEvents = True : Exit Sub : End With : NoFind

OK - this one should be put in Sheet1 code. All your data to be searched is in Sheet1 and the
name to be searched is in Sheet(D4).

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
If Not Application.Intersect(Target, sh1.[D4]) Is Nothing Then
With sh2
.Range(.Cells(2, 5), .Cells(2, 5).End(xlDown)).Clear
.Range(.Cells(5, 1), .Cells(5, 1).End(xlDown)).Clear
.Range(.Cells(8, 1), .Cells(8, 1).End(xlDown)).Clear
.Range(.Cells(8, 5), .Cells(8, 5).End(xlDown)).Clear
.Range(.Cells(8, 7), .Cells(8, 7).End(xlDown)).Clear
.Cells(2, 1).ClearContents
End With
With sh1
Dim Cust
Cust = .[D4]
Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer
n = 0
o = 0
p = 0
q = 0
r = 0
Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not c Is Nothing Then
firstc = c.Address
c.Copy Destination:=sh2.[A2]
Do
If c.Offset(0, 1) <> "" Then
c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0)
n = n + 1
Else
End If
If c.Offset(0, 2) <> "" Then
c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0)
o = o + 1
Else
End If
If c.Offset(0, 3) <> "" Then
c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0)
p = p + 1
Else
End If
If c.Offset(0, 4) <> "" Then
c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0)
q = q + 1
Else
End If
If c.Offset(0, 5) <> "" Then
c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0)
r = r + 1
Else
End If
Set c = .Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstc
End If
End With
End If
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

Any good?

Regards

Thanks again, but the way I wanted it was that the target cells are on sheet 1 and the search stays on sheet 2. Hope you can help me? Thanks : Thinking about it, it makes no sense to clear the sheet if you enter something somewhere : other than D4 - this corrects that. By the way, the search is case sensitive. : Private Sub Worksheet_Change(ByVal Target As Excel.Range) : Dim sh1 As Worksheet, sh2 As Worksheet : Set sh1 = Worksheets("Sheet1") : Set sh2 = Worksheets("Sheet2") : Application.EnableEvents = False : With sh2 : If Not Application.Intersect(Target, .[D4]) Is Nothing Then : .Range(Cells(2, 5), Cells(2, 5).End(xlDown)).Clear : .Range(Cells(5, 1), Cells(5, 1).End(xlDown)).Clear : .Range(Cells(8, 1), Cells(8, 1).End(xlDown)).Clear : .Range(Cells(8, 5), Cells(8, 5).End(xlDown)).Clear : .Range(Cells(8, 7), Cells(8, 7).End(xlDown)).Clear : .Cells(2, 1).Clear : Dim Cust : Cust = .[D4] : Else : GoTo NoFind : End If : End With : With sh1 : Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer : n = 0 : o = 0 : p = 0 : q = 0 : r = 0 : Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True) : If Not c Is Nothing Then : firstc = c.Address : c.Copy Destination:=sh2.[A2] : Do : If c.Offset(0, 1) <> "" Then : c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0) : n = n + 1 : Else : End If : If c.Offset(0, 2) <> "" Then : c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0) : o = o + 1 : Else : End If : If c.Offset(0, 3) <> "" Then : c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0) : p = p + 1 : Else : End If : If c.Offset(0, 4) <> "" Then : c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0) : q = q + 1 : Else : End If : If c.Offset(0, 5) <> "" Then : c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0) : r = r + 1 : Else : End If : Set c = .Columns(1).FindNext(c) : Loop While Not c Is Nothing And c.Address <> firstc : End If : End With : NoFind

Thanks again but still not working the way I want. Sorry for all the trouble. I've got on sheet1 all the data to be searched and I want it to be put on sheet1 also but the value to be searched is in sheet2(D4). So that's all that's in sheet2. And I don't know if it matters but it's all on workbook2 while workbook1 is also running. Does this matter? I hope you can help me? Thanks! OK - this one should be put in Sheet1 code. All your data to be searched is in Sheet1 and the name to be searched is in Sheet(D4). Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet2") If Not Application.Intersect(Target, sh1.[D4]) Is Nothing Then With sh2 .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown)).Clear .Range(.Cells(5, 1), .Cells(5, 1).End(xlDown)).Clear .Range(.Cells(8, 1), .Cells(8, 1).End(xlDown)).Clear .Range(.Cells(8, 5), .Cells(8, 5).End(xlDown)).Clear .Range(.Cells(8, 7), .Cells(8, 7).End(xlDown)).Clear .Cells(2, 1).ClearContents End With With sh1 Dim Cust Cust = .[D4] Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer n = 0 o = 0 p = 0 q = 0 r = 0 Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True) firstc = c.Address c.Copy Destination:=sh2.[A2] Do If c.Offset(0, 1) <> "" Then c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0) Else End If If c.Offset(0, 2) <> "" Then c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0) o = o + 1 Else End If If c.Offset(0, 3) <> "" Then c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0) p = p + 1 Else End If If c.Offset(0, 4) <> "" Then c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0) q = q + 1 Else End If If c.Offset(0, 5) <> "" Then c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0) r = r + 1 Else End If Set c = .Columns(1).FindNext(c) Loop While Not c Is Nothing And c.Address <> firstc Set sh1 = Nothing Set sh2 = Nothing Any good? Regards

OK, but before we do that - what has Workbook 1 got to do with it?

Is it somehow interacting with Workbook2 by input of the data to search or something?

Regards

Thanks again but still not working the way I want. Sorry for all the trouble. I've got on sheet1 all the data to be searched and I want it to be put on sheet1 also but the value to be searched is in sheet2(D4). So that's all that's in sheet2. And I don't know if it matters but it's all on workbook2 while workbook1 is also running. Does this matter? I hope you can help me? Thanks! : OK - this one should be put in Sheet1 code. All your data to be searched is in Sheet1 and the : name to be searched is in Sheet(D4). : Private Sub Worksheet_Change(ByVal Target As Excel.Range) : Dim sh1 As Worksheet, sh2 As Worksheet : Set sh1 = Worksheets("Sheet1") : Set sh2 = Worksheets("Sheet2") : If Not Application.Intersect(Target, sh1.[D4]) Is Nothing Then : With sh2 : .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown)).Clear : .Range(.Cells(5, 1), .Cells(5, 1).End(xlDown)).Clear : .Range(.Cells(8, 1), .Cells(8, 1).End(xlDown)).Clear : .Range(.Cells(8, 5), .Cells(8, 5).End(xlDown)).Clear : .Range(.Cells(8, 7), .Cells(8, 7).End(xlDown)).Clear : .Cells(2, 1).ClearContents : End With : With sh1 : Dim Cust : Cust = .[D4] : Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer : n = 0 : o = 0 : p = 0 : q = 0 : r = 0 : Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True) : If Not c Is Nothing Then : firstc = c.Address : c.Copy Destination:=sh2.[A2] : Do : If c.Offset(0, 1) <> "" Then : c.Offset(0, 1).Copy Destination:=sh2.[E2].Offset(n, 0) : n = n + 1 : Else : End If : If c.Offset(0, 2) <> "" Then : c.Offset(0, 2).Copy Destination:=sh2.[A5].Offset(o, 0) : o = o + 1 : Else : End If : If c.Offset(0, 3) <> "" Then : c.Offset(0, 3).Copy Destination:=sh2.[A8].Offset(p, 0) : p = p + 1 : Else : End If : If c.Offset(0, 4) <> "" Then : c.Offset(0, 4).Copy Destination:=sh2.[E8].Offset(q, 0) : q = q + 1 : Else : End If : If c.Offset(0, 5) <> "" Then : c.Offset(0, 5).Copy Destination:=sh2.[G8].Offset(r, 0) : r = r + 1 : Else : End If : Set c = .Columns(1).FindNext(c) : Loop While Not c Is Nothing And c.Address <> firstc : End If : End With : End If : Set sh1 = Nothing : Set sh2 = Nothing : End Sub : Any good? : Regards

I think I understand what you meant. Anyway, here is the amended code (goes in Sheet2 code).

Since you have the results and the initial data in the same sheet, make sure there will always
be at least one empty row above the data being searched - if you don't, the code may clear
some of that data as it has no way of knowing where it begins.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
If Not Application.Intersect(Target, sh2.[D4]) Is Nothing Then
Dim Cust
Cust = sh2.[D4]
With sh1
.Cells(2, 1).ClearContents
For Each c In .[A5, A8, E2, E8, G8]
If c <> "" Then
If c.Offset(1, 0) <> "" Then
.Range(c, c.End(xlDown)).Clear
Else
c.Clear
End If
Else
End If
Next c
Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer
n = 0
o = 0
p = 0
q = 0
r = 0
Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not c Is Nothing Then
firstc = c.Address
c.Copy Destination:=.[A2]
Do
If c.Address = "$A$2" Then GoTo Fin
If c.Offset(0, 1) <> "" Then
c.Offset(0, 1).Copy Destination:=.[E2].Offset(n, 0)
n = n + 1
Else
End If
If c.Offset(0, 2) <> "" Then
c.Offset(0, 2).Copy Destination:=.[A5].Offset(o, 0)
o = o + 1
Else
End If
If c.Offset(0, 3) <> "" Then
c.Offset(0, 3).Copy Destination:=.[A8].Offset(p, 0)
p = p + 1
Else
End If
If c.Offset(0, 4) <> "" Then
c.Offset(0, 4).Copy Destination:=.[E8].Offset(q, 0)
q = q + 1
Else
End If
If c.Offset(0, 5) <> "" Then
c.Offset(0, 5).Copy Destination:=.[G8].Offset(r, 0)
r = r + 1
Else
End If
Set c = .Columns(1).FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstc
End If
End With
End If
Fin:
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

Does this do it?

Regards

OK, but before we do that - what has Workbook 1 got to do with it? Is it somehow interacting with Workbook2 by input of the data to search or something? Regards

: Thanks again but still not working the way I want. Sorry for all the trouble. I've got on sheet1 all the data to be searched and I want it to be put on sheet1 also but the value to be searched is in sheet2(D4). So that's all that's in sheet2. And I don't know if it matters but it's all on workbook2 while workbook1 is also running. Does this matter? I hope you can help me? Thanks!

Thanks! It works! Sorry I didn't respond sooner but I was sick! But thanks a million!!! I think I understand what you meant. Anyway, here is the amended code (goes in Sheet2 code). Since you have the results and the initial data in the same sheet, make sure there will always be at least one empty row above the data being searched - if you don't, the code may clear some of that data as it has no way of knowing where it begins. Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = ThisWorkbook.Worksheets("Sheet1") Set sh2 = ThisWorkbook.Worksheets("Sheet2") If Not Application.Intersect(Target, sh2.[D4]) Is Nothing Then Dim Cust Cust = sh2.[D4] With sh1 .Cells(2, 1).ClearContents For Each c In .[A5, A8, E2, E8, G8] If c <> "" Then If c.Offset(1, 0) <> "" Then .Range(c, c.End(xlDown)).Clear Else c.Clear End If Next c Dim n As Integer, o As Integer, p As Integer, q As Integer, r As Integer n = 0 o = 0 p = 0 q = 0 r = 0 Set c = .Columns(1).Find(Cust, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True) firstc = c.Address c.Copy Destination:=.[A2] Do If c.Address = "$A$2" Then GoTo Fin If c.Offset(0, 1) <> "" Then c.Offset(0, 1).Copy Destination:=.[E2].Offset(n, 0) Else End If If c.Offset(0, 2) <> "" Then c.Offset(0, 2).Copy Destination:=.[A5].Offset(o, 0) o = o + 1 Else End If If c.Offset(0, 3) <> "" Then c.Offset(0, 3).Copy Destination:=.[A8].Offset(p, 0) p = p + 1 Else End If If c.Offset(0, 4) <> "" Then c.Offset(0, 4).Copy Destination:=.[E8].Offset(q, 0) q = q + 1 Else End If If c.Offset(0, 5) <> "" Then c.Offset(0, 5).Copy Destination:=.[G8].Offset(r, 0) r = r + 1 Else End If Set c = .Columns(1).FindNext(c) Loop While Not c Is Nothing And c.Address <> firstc Fin: Set sh1 = Nothing Set sh2 = Nothing Does this do it? Regards