Can I copy FndPrd to a list on the same sheet and/or to another sheet.
What I have gives me TRUE in K2 and I have marching ants around the
..Union arguments 1 & 2 and 3 & 4 on the sheet.

Thanks,
Howard

Option Explicit
Option Compare Text

Sub TheUnionOf()

Dim FndPrd As String
Dim c As Range

FndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If c = FndPrd Then
Set FndPrd = Application.Union(c.Offset(0, 1), c.Offset(0, 2), c.Offset(0, 4), c.Offset(0, 5))
Range("K100").End(xlUp).Offset(1, 0) = FndPrd
End If

Next
End Sub

Hi Howard,

Am Fri, 27 Sep 2013 23:55:51 -0700 (PDT) schrieb Howard:

Can I copy FndPrd to a list on the same sheet and/or to another sheet.
What I have gives me TRUE in K2 and I have marching ants around the
.Union arguments 1 & 2 and 3 & 4 on the sheet.

try:

Sub TheUnionOf2()
Dim rngFndPrd As Range
Dim sFndPrd As String
Dim c As Range

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If c = sFndPrd Then
Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _
c.Offset(0, 4), c.Offset(0, 5))
rngFndPrd.Copy
Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteAll, Transpose:=True
End If
Next
End Sub

or:

Sub TheUnionOf()
Dim strFndPrd As String
Dim sFndPrd As String
Dim varOut As Variant
Dim c As Range

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If c = sFndPrd Then
strFndPrd = c.Offset(0, 1) & "," & c.Offset(0, 2) & "," & _
c.Offset(0, 4) & "," & c.Offset(0, 5)
varOut = Split(strFndPrd, ",")
Range("K100").End(xlUp).Offset(1, 0) _
.Resize(rowsize:=UBound(varOut) + 1) = _
WorksheetFunction.Transpose(varOut)
End If
Next
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Saturday, September 28, 2013 12:25:42 AM UTC-7, Claus Busch wrote:
Hi Howard,



Am Fri, 27 Sep 2013 23:55:51 -0700 (PDT) schrieb Howard:



Can I copy FndPrd to a list on the same sheet and/or to another sheet.

What I have gives me TRUE in K2 and I have marching ants around the

.Union arguments 1 & 2 and 3 & 4 on the sheet.



try:



Sub TheUnionOf2()

Dim rngFndPrd As Range

Dim sFndPrd As String

Dim c As Range



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)



For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

If c = sFndPrd Then

Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _

c.Offset(0, 4), c.Offset(0, 5))

rngFndPrd.Copy

Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _

Paste:=xlPasteAll, Transpose:=True

End If

Next

End Sub



or:



Sub TheUnionOf()

Dim strFndPrd As String

Dim sFndPrd As String

Dim varOut As Variant

Dim c As Range



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)



For Each c In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

If c = sFndPrd Then

strFndPrd = c.Offset(0, 1) & "," & c.Offset(0, 2) & "," & _

c.Offset(0, 4) & "," & c.Offset(0, 5)

varOut = Split(strFndPrd, ",")

Range("K100").End(xlUp).Offset(1, 0) _

.Resize(rowsize:=UBound(varOut) + 1) = _

WorksheetFunction.Transpose(varOut)

End If

Next

End Sub





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2

Thanks, Claus. Both run smooth and good as gold.

Regards,
Howard

Hi Howard,

Am Sat, 28 Sep 2013 00:50:09 -0700 (PDT) schrieb Howard:

Both run smooth and good as gold.

it will run a bit faster if you use the find method instead of looping
through the range:

Sub TheUnionOf2()
Dim rngFndPrd As Range
Dim sFndPrd As String
Dim c As Range
Dim LRow As Long

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

LRow = Cells(Rows.Count, 1).End(xlUp).Row
Set c = Range("A1:A" & LRow).Find(sFndPrd, LookIn:=xlValues)
If Not c Is Nothing Then
Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _
c.Offset(0, 4), c.Offset(0, 5))
rngFndPrd.Copy
Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteAll, Transpose:=True
End If
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

it will run a bit faster if you use the find method instead of looping

through the range:



Sub TheUnionOf2()

Dim rngFndPrd As Range

Dim sFndPrd As String

Dim c As Range

Dim LRow As Long



sFndPrd = Application.InputBox("Enter Col A Item.", _

"Col A Finder", , , , , , 2)



LRow = Cells(Rows.Count, 1).End(xlUp).Row

Set c = Range("A1:A" & LRow).Find(sFndPrd, LookIn:=xlValues)

If Not c Is Nothing Then

Set rngFndPrd = Union(c.Offset(0, 1), c.Offset(0, 2), _

c.Offset(0, 4), c.Offset(0, 5))

rngFndPrd.Copy

Range("K100").End(xlUp).Offset(1, 0).PasteSpecial _

Paste:=xlPasteAll, Transpose:=True

End If

End Sub


Regards

Claus B.


I'll give it a go. I'm using the codes on a small test data set, actual use could be around 5500+ rows.

I'm sure that will make a BIG difference.

Thanks, Claus.

Appreciate it.

Regards,
Howard

Hi Howard,

Am Sat, 28 Sep 2013 03:33:06 -0700 (PDT) schrieb Howard:

I'll give it a go. I'm using the codes on a small test data set, actual use could be around 5500+ rows.

can your search string be found more than once? Then try:

Sub TheUnionOf3()
Dim varOut() As Variant
Dim sFndPrd As String
Dim c As Range
Dim LRow As Long
Dim firstaddress As String
Dim i As Integer
Dim j As Integer
Dim myCount As Integer

sFndPrd = Application.InputBox("Enter Col A Item.", _
"Col A Finder", , , , , , 2)

LRow = Cells(Rows.Count, 1).End(xlUp).Row
myCount = WorksheetFunction.CountIf(Range("A1:A" & LRow), sFndPrd)
With Range("A1:A" & LRow)
i = 1
Set c = .Find(sFndPrd, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
ReDim Preserve varOut(myCount, 4)
varOut(i, 1) = c.Offset(0, 1)
varOut(i, 2) = c.Offset(0, 2)
varOut(i, 3) = c.Offset(0, 4)
varOut(i, 4) = c.Offset(0, 5)
Set c = .FindNext(c)
i = i + 1
Loop While Not c Is Nothing And c.Address < firstaddress
End If
.Cells(Rows.Count, "K").End(xlUp)(2) _
.Resize(myCount, 4) = varOut
' .Cells(Rows.Count, "K").End(xlUp)(2) _
' .Resize(4, myCount) = WorksheetFunction.Transpose(varOut)
End With
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2