Hi Howard,

Am Thu, 25 Jun 2015 08:38:15 +0200 schrieb Claus Busch:

If Application.CountA(Nme.Offset(, 1).Resize(1, 41)) = 0 Then
rngFound.Offset(, 1).Resize(1, 41).Copy Nme.Offset(, 1)
Else
rngFound.Resize(1, 42).Copy _
Sheets("Input").Cells(Rows.Count, 1).End(xlUp)(2)
End If

better and faster without copying:

Sub Nme_Find()
Dim rngFound As Range
Dim Nme As Range
Dim OneRng As Range
Dim FirstAddress As String

Set OneRng = Sheets("Input").Range("A2:A" & Cells(Rows.Count,
"A").End(xlUp).Row)

Application.ScreenUpdating = False
For Each Nme In OneRng
Set rngFound = Sheets("Output").Range("A:A").Find(What:=Nme.Value , _
LookIn:=xlValues, _
LookAt:=xlWhole)

If Not rngFound Is Nothing Then
FirstAddress = rngFound.Address
Do
If Application.CountA(Nme.Offset(, 1).Resize(1, 41)) = 0
Then
Nme.Offset(, 1).Resize(1, 41).Value = _
rngFound.Offset(, 1).Resize(1, 41).Value
Else
Sheets("Input").Cells(Rows.Count, 1).End(xlUp)(2). _
Resize(1, 42).Value = rngFound.Resize(1, 42).Value
End If
Set rngFound = Sheets("Output").Range("A:A").FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <
FirstAddress
End If
Next
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

better and faster without copying:

Sub Nme_Find()
Dim rngFound As Range
Dim Nme As Range
Dim OneRng As Range
Dim FirstAddress As String

Set OneRng = Sheets("Input").Range("A2:A" & Cells(Rows.Count,
"A").End(xlUp).Row)

Application.ScreenUpdating = False
For Each Nme In OneRng
Set rngFound = Sheets("Output").Range("A:A").Find(What:=Nme.Value , _
LookIn:=xlValues, _
LookAt:=xlWhole)

If Not rngFound Is Nothing Then
FirstAddress = rngFound.Address
Do
If Application.CountA(Nme.Offset(, 1).Resize(1, 41)) = 0
Then
Nme.Offset(, 1).Resize(1, 41).Value = _
rngFound.Offset(, 1).Resize(1, 41).Value
Else
Sheets("Input").Cells(Rows.Count, 1).End(xlUp)(2). _
Resize(1, 42).Value = rngFound.Resize(1, 42).Value
End If
Set rngFound = Sheets("Output").Range("A:A").FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <
FirstAddress
End If
Next
Application.ScreenUpdating = True
End Sub


Hi Claus,

I am thinking this does what I want, but over writes old list on Output.

I changed this line to list in column C but the first entry is in B and the rest are in C.

Sheets("Input").Cells(Rows.Count, 2).End(xlUp)(2). _
Resize(1, 42).Value = rngFound.Resize(1, 42).Value

Can't find what is making first return in B and others in C.

Maybe I'm screwed up, I'll keep checking on it.

Howard

On Thursday, June 25, 2015 at 12:36:57 AM UTC-7, L. Howard wrote:
better and faster without copying:

Sub Nme_Find()
Dim rngFound As Range
Dim Nme As Range
Dim OneRng As Range
Dim FirstAddress As String

Set OneRng = Sheets("Input").Range("A2:A" & Cells(Rows.Count,
"A").End(xlUp).Row)

Application.ScreenUpdating = False
For Each Nme In OneRng
Set rngFound = Sheets("Output").Range("A:A").Find(What:=Nme.Value , _
LookIn:=xlValues, _
LookAt:=xlWhole)

If Not rngFound Is Nothing Then
FirstAddress = rngFound.Address
Do
If Application.CountA(Nme.Offset(, 1).Resize(1, 41)) = 0
Then
Nme.Offset(, 1).Resize(1, 41).Value = _
rngFound.Offset(, 1).Resize(1, 41).Value
Else
Sheets("Input").Cells(Rows.Count, 1).End(xlUp)(2). _
Resize(1, 42).Value = rngFound.Resize(1, 42).Value
End If
Set rngFound = Sheets("Output").Range("A:A").FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <
FirstAddress
End If
Next
Application.ScreenUpdating = True
End Sub


Hi Claus,

I am thinking this does what I want, but over writes old list on Output.

I changed this line to list in column C but the first entry is in B and the rest are in C.

Sheets("Input").Cells(Rows.Count, 2).End(xlUp)(2). _
Resize(1, 42).Value = rngFound.Resize(1, 42).Value

Can't find what is making first return in B and others in C.

Maybe I'm screwed up, I'll keep checking on it.

Howard

Typo Sheets("Input").Cells(Rows.Count, 2).End(xlUp)(2).

should be Sheets("Input").Cells(Rows.Count, 3).End(xlUp)(2).

Howard

Hi Howard,

Am Thu, 25 Jun 2015 00:39:51 -0700 (PDT) schrieb L. Howard:

Typo Sheets("Input").Cells(Rows.Count, 2).End(xlUp)(2).

should be Sheets("Input").Cells(Rows.Count, 3).End(xlUp)(2).

sorry I don't understand.
Why do you want to bring the data ometimers to column A and sometimes to
C?
Can you show me the layout of the tables and the expected result if a
Nme occurs more than once?


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

sorry I don't understand.
Why do you want to bring the data ometimers to column A and sometimes to
C?
Can you show me the layout of the tables and the expected result if a
Nme occurs more than once?

Sure, I believe this will show it.

Actually I am open to how the data comes back to Input, But I want to keep original Input sheet column A intact and list the results in column C.

I suspect there will need to be a sort to group the same Nme's together. My example has numbers but the real data will most likely be just words.

I limited rows of data but there will be about 41+- on Output.

Sheet Input column A

Header
input-1
input-2
input-3
input-4
input-6
input-8
input-10
input-11
input-12
input-13

Sheet Output Col A - D (40+- more rows)

Header
input-1 data 1 and More cells
input-2 data 2 and More cells
input-3 data 3 and More cells
input-1 data 4 and More cells
input-5 data 5 and More cells
input-6 data 6 and More cells
input-7 data 7 and More cells
input-8 data 8 and More cells
input-9 data 9 and More cells
input-10 data 10 and More cells
input-11 data 11 and More cells
input-8 data 12 and More cells
input-13 data 13 and More cells
input-13 data 14 and More cells

Sheet Input results

Header
input-1 input-1 data 1 and More cells
input-2 input-1 data 4 and More cells
input-3 input-2 data 2 and More cells
input-4 input-3 data 3 and More cells
input-6 input-6 data 6 and More cells
input-8 input-8 data 8 and More cells
input-10 input-8 data 12 and More cells
input-11 input-10 data 10 and More cells
input-12 input-11 data 11 and More cells
input-13 input-13 data 13 and More cells
input-13 data 14 and More cells


Hope the format hold together.

My Drop Box is down with some sort of problem.

Howard

My Drop Box is down with some sort of problem.

Howard

Ahaa! Drop Box working now.

https://www.dropbox.com/s/jyawocfar9...Copy.xlsm?dl=0

This might be better.

Howard

Hi Howard,

Am Thu, 25 Jun 2015 02:27:26 -0700 (PDT) schrieb L. Howard:

https://www.dropbox.com/s/jyawocfar9...Copy.xlsm?dl=0

that is easier to handle.
Try:

Sub Nme_Find_Exp()
Dim rngFound As Range, Nme As Range
Dim OneRng As Range, rngBig As Range
Dim FirstAddress As String

Set OneRng = Sheets("Input").Range("A2:A" & Cells(Rows.Count,
"A").End(xlUp).Row)

For Each Nme In OneRng

Set rngFound = Sheets("Output").Range("A:A").Find(What:=Nme.Value , _
LookIn:=xlValues, _
LookAt:=xlWhole)


If Not rngFound Is Nothing Then

FirstAddress = rngFound.Address
Do
If rngBig Is Nothing Then
Set rngBig = rngFound.Resize(1, 42)
Else
Set rngBig = Union(rngBig, rngFound.Resize(1, 42))
End If
Set rngFound = Sheets("Output").Range("A:A").FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <
FirstAddress

End If
Next
Sheets("Input").Range("C2").Resize(rngBig.Rows.Cou nt, 42).Value =
rngBig.Value
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Hi Howard,

Am Thu, 25 Jun 2015 02:27:26 -0700 (PDT) schrieb L. Howard:

https://www.dropbox.com/s/jyawocfar9...Copy.xlsm?dl=0

ignore the last answer and try it this way:

Sub Nme_Find_Exp()
Dim rngFound As Range, Nme As Range
Dim OneRng As Range, rngBig As Range
Dim FirstAddress As String

Set OneRng = Sheets("Input").Range("A2:A" & Cells(Rows.Count,
"A").End(xlUp).Row)

For Each Nme In OneRng

Set rngFound = Sheets("Output").Range("A:A").Find(What:=Nme.Value , _
LookIn:=xlValues, _
LookAt:=xlWhole)


If Not rngFound Is Nothing Then

FirstAddress = rngFound.Address
Do
Sheets("Input").Cells(Rows.Count, 3).End(xlUp)(2) _
.Resize(1, 42).Value = rngFound.Resize(1, 42).Value
Set rngFound = Sheets("Output").Range("A:A").FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <
FirstAddress

End If
Next
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional